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"
-------------------------------------------------------------------------------------------------------------------------------------RRun 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)
-----------------------------------------------------------------------
