Tips and Tricks |
Write to a file: filename = text1.text if filename = "" then goto errhandl step1 = text2.text open filname for output as #1 print #1, step1 close #1 exit sub errhandl: msgbox "Please enter a filename" -------------------------------------------------------------------------------- Read from a file: filename = text1.text if filename = "" then exit sub open filename for input as #1 input #1, step1 close #1 text2.text = step1 -------------------------------------------------------------------------------- Copy & Paste: Copy: clipboard.settext form1.text1.seltext Paste: form1.text1.seltext = clipboard.gettext() -------------------------------------------------------------------------------- Communication: Initialize the COM-port: Comm1.CommPort = 2 Comm1.Settings = "14400,N,8,1" -------------------------------------------------------------------------------- Dial a number: Comm1.PortOpen = True Comm1.OutPut = "ATDT" + text1.text + Chr$(13) 'text1.text = the number you want to dial and Chr$(13) is ENTER -------------------------------------------------------------------------------- Close the COM-port: Comm1.PortOpen = False -------------------------------------------------------------------------------- The "\" problem: If Right(Dir1.Path,1) <> "\" Then Text1.Text = Dir1.Path & "\" & File1.FileName Else Text1.Text = Dir1.Path & File1.FileName End If -------------------------------------------------------------------------------- Message boxes: Syntax: MsgBox("message",type,"titel") Ex: MsgBox("Do you want to start the program?",4,"Start Program?") -------------------------------------------------------------------------------- Copy file: Text1.Text = c:\dev\vb16\vb.exe Text2.Text = c:\dev\exes\ FileCopy Text1,Text2 -------------------------------------------------------------------------------- Delete file: Text1.Text = c:\temp\wrong.zip Kill Text1 -------------------------------------------------------------------------------- Create a directory: Text1.Text = c:\dev\temp MkDir Text1.Text -------------------------------------------------------------------------------- Delete a directory: Text1.Text = c:\dev\temp RmDir Text1 -------------------------------------------------------------------------------- Rename a file: Text1.Text = vb3.txt Text2.Text = vb4.txt Name Text1 As Text2 -------------------------------------------------------------------------------- Delete the last character in a textbox: Text1 = Left(Text1, Len(Text1) - 1) -------------------------------------------------------------------------------- Check Mousebutton: If Button = 1 Then MsgBox "You have pressed the LEFT button" If Button = 2 Then MsgBox "You have pressed the RIGHT button" If Button = 3 Then MsgBox "You have pressed the LEFT and RIGHT button" If Button = 4 Then MsgBox "You have pressed the MIDDLE button" -------------------------------------------------------------------------------- If-Then: If Text1.Text = Text2.Text Then Text3.Text = "Hello world" End If -------------------------------------------------------------------------------- Do-While: HomeAlone = True Do While HomeAlone = True Text1.Text = "Are your parents home?" If txtAnswer.Text = "Yes" Then HomeAlone = False Loop -------------------------------------------------------------------------------- Do Loop While: HomeAlone = True Do Text1.Text = "Are your parents home?" If txtAnswer.Text = "Yes" Then HomeAlone = False Lopp While HomeAlone = True -------------------------------------------------------------------------------- Do Until: HomeAlone = True Do Until HomeAlone = False Text1.Text = "Are you home alone?" If txtAnswer.Text = "No" Then HomeAlone = False Loop -------------------------------------------------------------------------------- Select Case: Dim Grade as string Select Case Grade Case "A": Label1.Caption = "WOW" Case "B": Label1.Caption = "Very Good" Case "C": Label1.Caption = "OK" Case else: Label1.Caption = "You Suck" -------------------------------------------------------------------------------- LoadPicture: Image1.picture = Loadpicture("C:\picture.jpg") Clear Picturebox: LoadPicture() -------------------------------------------------------------------------------- Screen Resolution: CR$ = Chr$(13) + Chr$(10) TWidth% = screen.Width \ screen.TwipsPerPixelX THeight% = screen.Height \ screen.TwipsPerPixelY MsgBox "Screen Resolution:" + CR$ + CR$ + Str$(TWidth%) + " x" + Str$(THeight%), 64, "Info" -------------------------------------------------------------------------------------------------------------------------------------R Run Another Program: call shell(filename) ----------------------------------------------------------------------- Count how many lines there are in a text file: 'need a button and two text boxes Private Sub Command1_Click() Dim FileNum As Integer Dim StrBuffer As String Dim ReadLine As Integer FileNum = FreeFile Open Text1.Text For Input As #FileNum Do While Not EOF(FileNum) Input #FileNum, StrBuffer ReadLine = ReadLine + 1 Loop Close #FileNum Text2.Text = ReadLine End Sub ----------------------------------------------------------------------- How to play a wav sound: Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long i = sndPlaySound(ByVal CStr(App.Path & "\ramenu1.wav"), SND_ASYNC) ----------------------------------------------------------------------- Cusor Functions like getting cursor postion and hiding the cursor: 'Declare the GetCursorPos API Function and the appropriate type Private Declare Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As Long Type PointAPI x As Long y As Long End Type Dim CursorPosition As PointAPI 'Declare the ShowCursor API Function Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long 'A couple constants to make things clearer: Const CURVISIBLE = 1 Const CURINVISIBLE = 0 Dim CursorState As Boolean 'Variable to keep track of the state of the cursor Public Sub Initialize() 'Have to initialize the CursorState to false CursorState = True ShowCursor CURVISIBLE End Sub Public Sub CursorToggle() 'Check if the cursor is presently visible or not Select Case CursorState Case True 'If the cursor is visible... 'Make it invisible CursorState = False ShowCursor CURINVISIBLE Case False 'If the cursor is invisible... 'Make it visible CursorState = True ShowCursor CURVISIBLE End Select End Sub Public Function xPos() 'Returns the x-position of the cursor GetCursorPos CursorPosition xPos = CursorPosition.x End Function Public Function yPos() 'Returns the y-position of the cursor GetCursorPos CursorPosition yPos = CursorPosition.y End Function Public Sub Terminate() 'When the form unloads, we want to ensure that 'the cursor is back, or else it stays invisible 'even after the program's done! ShowCursor CURVISIBLE End Sub ----------------------------------------------------------------------- More text box functions! Option Explicit 'API function declarations Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long 'Window messages sent to the textbox Private Const EM_CANUNDO = &HC6 Private Const EM_GETFIRSTVISIBLELINE = &HCE Private Const EM_GETLINE = &HC4 Private Const EM_GETLINECOUNT = &HBA Private Const EM_GETMODIFY = &HB8 Private Const EM_LINEFROMCHAR = &HC9 Private Const EM_LINEINDEX = &HBB Private Const EM_LINELENGTH = &HC1 Private Const EM_SETMODIFY = &HB9 Private Const EM_UNDO = &HC7 'local variables to hold property values Private WithEvents mtxtBox As TextBox Private mhWnd As Long 'the hWnd of the textbox Public Function LineLen(CharPos As Long) 'Returns the number of character of the line that 'contains the character position specified by CharPos LineLen = SendMessage(mhWnd, EM_LINELENGTH, CharPos, 0&) End Function Public Function GetLineFromChar(CharPos As Long) As Long 'Returns the zero based line number of the line 'that contains the specified character index GetLineFromChar = SendMessage(mhWnd, EM_LINEFROMCHAR, CharPos, 0&) End Function Public Function LineCount() As Long 'Returns the number of lines in the textbox LineCount = SendMessage(mhWnd, EM_GETLINECOUNT, 0&, 0&) End Function Public Function TopLine() As Long 'Returns the zero based line index of the first 'visible line in a multiline textbox. 'Or the position of the first visible character 'in a none multiline textbox TopLine = SendMessage(mhWnd, EM_GETFIRSTVISIBLELINE, 0&, 0&) End Function Public Function CanUndo() As Boolean 'Returns True if it's possible to make an Undo Dim lngRetVal As Long lngRetVal = SendMessage(mhWnd, EM_CANUNDO, 0&, 0&) CanUndo = (lngRetVal <> 0) End Function Public Function GetCharFromLine(LineIndex As Long) 'Returns the index of the first character of the line 'check if LineIndex is valid If LineIndex < LineCount Then GetCharFromLine = SendMessage(mhWnd, EM_LINEINDEX, LineIndex, 0&) End If End Function Public Function GetLine(LineIndex As Long) As String 'Returns the text contained at the specified line Dim bArray() As Byte 'byte array to contain the returned string Dim lngLineLen As Long 'the length of the line Dim sRetVal As String 'the return value 'Check the LineIndex value If LineIndex >= LineCount Then GetLine = "" Exit Function End If 'get the length of the line lngLineLen = LineLen(GetCharFromLine(LineIndex)) If lngLineLen < 1 Then GetLine = "" Exit Function End If ReDim bArray(lngLineLen + 1) 'The first word of the array must contain 'the length of the line to return bArray(0) = lngLineLen And 255 bArray(1) = lngLineLen \ 256 SendMessage mhWnd, EM_GETLINE, LineIndex, bArray(0) 'convert the byte array into a string sRetVal = Left(StrConv(bArray, vbUnicode), lngLineLen) 'return the string GetLine = sRetVal End Function Public Sub Undo() 'Undo the last edit SendMessage mhWnd, EM_UNDO, 0&, 0& End Sub Public Sub DelLine(LineIndex As Long) 'Deletes the specified line from the textbox Dim lngSelStart As Long 'used to save the caret position Dim lngLineLen As Long 'the length of the line to delete Dim lngCharPos As Long 'the index of the first character on the line If LineIndex >= LineCount Then Exit Sub End If lngSelStart = mtxtBox.SelStart lngCharPos = GetCharFromLine(LineIndex) lngLineLen = LineLen(lngCharPos) mtxtBox = Left$(mtxtBox, lngCharPos) & Mid$(mtxtBox, lngCharPos + lngLineLen + 1) mtxtBox.SelStart = lngSelStart End Sub Public Property Let IsDirty(ByVal blnDirty As Boolean) Dim lngDirty As Long lngDirty = Abs(blnDirty) '1 = True in API functions not -1 as in VB SendMessage mhWnd, EM_SETMODIFY, lngDirty, 0& End Property Public Property Get IsDirty() As Boolean IsDirty = (SendMessage(mhWnd, EM_GETMODIFY, 0&, 0&) <> 0) End Property Public Property Set TextBox(txtNewBox As TextBox) Set mtxtBox = txtNewBox mhWnd = txtNewBox.hwnd End Property Public Property Get TextBox() As TextBox Set TextBox = mtxtBox End Property Private Sub mtxtBox_KeyDown(KeyCode As Integer, Shift As Integer) Dim lngLineIndex As Long If Shift = vbCtrlMask Then Select Case KeyCode Case vbKeyA 'CTRL+A = Select all With mtxtBox .SelStart = 0 .SelLength = Len(.Text) End With Case vbKeyY 'CTRL+Y = Cut current line and put it on the clipboard lngLineIndex = GetLineFromChar(mtxtBox.SelStart) Clipboard.SetText GetLine(lngLineIndex) DelLine GetLineFromChar(lngLineIndex) End Select End If End Sub ----------------------------------------------------------------------- Make a form cover the entrie screen! 'Task: Make a form cover the entire screen including taskbar and office toolbar 'Declarations 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 Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Const SM_CXSCREEN = 0 Const SM_CYSCREEN = 1 Const HWND_TOP = 0 Const SWP_SHOWWINDOW = &H40 'Code: Dim cx As Long Dim cy As Long Dim RetVal As Long ' Determine if screen is already maximized. If Me.WindowState = vbMaximized Then ' Set window to normal size Me.WindowState = vbNormal End If ' Get full screen width. cx = GetSystemMetrics(SM_CXSCREEN) ' Get full screen height. cy = GetSystemMetrics(SM_CYSCREEN) ' Call API to set new size of window. RetVal = SetWindowPos(Me.hwnd, HWND_TOP, 0, 0, cx, cy, SWP_SHOWWINDOW) ----------------------------------------------------------------------- Elliptic objects Declare Function CreateEllipticRgn Lib "gdi32" Alias "CreateEllipticRgn" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long and Declare Function SetWindowRgn Lib "user32" Alias "SetWindowRgn" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long Notes: These functions is measured in pixels. Everything in your elliptic object will work as usually. You have to use both of these functions to make it work. Parameters for the first function: X1: Where to start the ellipse, horizontal Y1: Where to start the ellipse, vertical X2: The diameter of the ellipse, horizonal Y2: The diameter of the ellipse, vertical Parameters for the second function: hWnd:The handel to the object(form,picturebox,textbox, etc) you want to make elliptic hRgn: The retcode from the function CreateEllipticRgn bRedraw: If you want to redraw your object with the new look. Set this to True Example: Dim retcode As Long retcode = CreateEllipticRgn(30, 0, 200, 200) SetWindowRgn Form1.hWnd, retcode, True ----------------------------------------------------------------------- Change Wallpaper 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 Notes:This function can perform many different things. It is worth testing a bit more but here will it only be used as a wallpaper changer. Some of the parameters is not used when changing wallpaper. You can only use bitmaps (*.bmp). Returns 0 if an error is found else will returns a value. Parameters: uAction:What you will change in windows. To change wallpaper use this constant Public Const SPI_SETDESKWALLPAPER = 20 uParam: Set this to 0 lpvParam: The path to the bitmap fuWinIni: Set this to 0 Example: SystemParametersInfo SPI_SETDESKWALLPAPER, 0, "C:\windows\clouds.bmp", 0 ----------------------------------------------------------------------- Set Pixel / Get Pixel Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long and Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long Notes: This funktion is used to manipulate pictures. It is very important when you create mask when animating. You don't have to use both functons at the same time. SetPixel sets the color of a pixel. GetPixel returns the color of a pixel. Parameters in SetPixel: hdc: The handle to the object(picturebox,form) in which the pixel will be set. x: The Pixels location, horizontal y: The Pixels location, vertical crcolor: The color you will set the pixel to. Parameters in GetPixel: hdc: The handle to the object(picturebox,form) where the pixel is located x: The Pixels location, horizontal y: The Pixels location, vertical Example: Dim color as Long Dim retcode as Long color = GetPixel(Picture1.hdc, 10, 50) retcode = SetPixel(Picture1.hdc, 10, 50, vbBlue) ----------------------------------------------------------------------- Move Form without CaptionBar Declare Function ReleaseCapture Lib "user32" () As Long and Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Notes: These functions are not created only for the purpose of moving forms so the parameters can be a bit odd. You have to use both functions. Put the function calls under Form_MouseDown. Parameters for the second function: hwnd: The handle to the moving form. wMsg: Use this constant Public Const WM_NCLBUTTONDOWN = &HA1 wParam: Use this constant Public Const LP_HT_CAPTION = 2 lParam: Set this to 0 Example: ReleaseCapture SendMessage hwnd, WM_NCLBUTTONDOWN, LP_HT_CAPTION, 0 ----------------------------------------------------------------------- Animating 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 Notes: This is a long one. It is used for many different parts in Animating. See the Game Development section for further information. The part that is going to be explained here is how you copy a part of a bitmap into a Picturebox. If you do this rapidly it will appear as if it moved on its own. These parameters are hard to explain so try to figure it out by yourself, of course with these guidelines. Parameters: hDestDC: The object(Picturebox) where the picture will be painted. x: Where in the object it will be painted, Horizontal. y: Where in the object it will be painted, Vertical. nWidth: The width of the picture which will be painted nHeight: The height of the picture which will be painted hSrcDC: The handle to the Picture. Often a Picturebox with the picture inside. xSrc: Which part of the Picture will be painted, Horizontal. ySrc: Which part of the Picture will be painted, Vertical. dwRop: This indicates how it will be painted. See the Game Development section for information. Use these constants: Const SRCCOPY = &HCC0020 Const SRCINVERT = &H660046 Const SRCPAINT = &HEE0086 Const SRCAND = &H8800C6 Example: ret = BitBlt(PicBox.hdc, 1, 1, 70, 70, picsource.hdc, 1, 1, SRCCOPY) ----------------------------------------------------------------------- |
Visual Basic Zone |
