Frequently Asked VB Questions

[dee-u]

In order to make this thread as tidy as possible pls. PM me all your comments, suggestions, improvements, modifications.... And pls. post only those that are only truly "Frequently Asked Questions".... Thanks!

1. How to read/write ini?

Option Explicit
 
'declares for ini controlling
Private Declare Function GetPrivateProfileSection Lib "kernel32" Alias "GetPrivateProfileSectionA" (ByVal lpAppName As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
 
Private 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
 
Private Declare Function WritePrivateProfileSection Lib "kernel32" Alias "WritePrivateProfileSectionA" (ByVal lpAppName As String, ByVal lpString As String, ByVal lpFileName As String) As Long
 
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
 
Private Sub Form_Load()
On Error Resume Next
 
Dim File As String, OFLen As Double,  Str As String
 
File = "C:\temp.txt"
OFLen = FileLen(File)
 
'write few example sections:
WriteIniSection File, "Test1", ""
WriteIniSection File, "Test2", "Here shoud be found some text"
 
'write few ini strings
WriteIni File, "Test3", "Ini1", "This is ini 1"
WriteIni File, "Test1", "Ini2", "This is ini 2"
 
'inform we're written the data
MsgBox Format((FileLen(File) - OFLen) / 1024, "0.00") & " KB data written to " & Chr(34) & File & Chr(34)
 
'read the ini file
Str = Str & "Test2 section: " & vbTab & ReadIniSection(File, "Test2") & vbCrLf
Str = Str & "Test1 section: " & vbTab & ReadIniSection(File, "Test1") & vbCrLf
Str = Str & "Ini1 string: " & vbTab & ReadIni(File, "Test3", "Ini1") & vbCrLf
Str = Str & "Ini2 string: " & vbTab & ReadIni(File, "Test1", "Ini2") & vbCrLf
 
'show data
MsgBox Str
 
'end application
End
 
End Sub
 
'// INI CONTROLLING PROCEDURES
 
'reads ini string
Public Function ReadIni(Filename As String, Section As String, Key As String) As String
Dim RetVal As String * 255, v As Long
v = GetPrivateProfileString(Section, Key, "", RetVal, 255, Filename)
ReadIni = Left(RetVal, v - 1)
End Function
 
'reads ini section
Public Function ReadIniSection(Filename As String, Section As String) As String
Dim RetVal As String * 255, v As Long
v = GetPrivateProfileSection(Section, RetVal, 255, Filename)
ReadIniSection = Left(RetVal, v - 1)
End Function
 
'writes ini
Public Sub WriteIni(Filename As String, Section As String, Key As String, Value As String)
WritePrivateProfileString Section, Key, Value, Filename
End Sub
 
'writes ini section
Public Sub WriteIniSection(Filename As String, Section As String, Value As String)
WritePrivateProfileSection Section, Value, Filename
End Sub

2. How to send e-mail?
Have a look at this official FAQ article: How do I send an email using Outlook

3.How to work with registry?

'Savesetting
Private Sub Form_Unload(Cancel As Integer) 
   SaveSetting "RegCust", "Startup", "Backup", strDate
   SaveSetting "RegCust", "Startup", "LastEntry",intLastEntry
End Sub
'GetSetting
Private Sub Form_Load()
   Dim intLastEntry As Integer
   intLastEntry = GetSetting("RegCust", "Startup", _
   "LastEntry", "0")
End Sub
'DeleteSetting
Private Sub cmdDelKey_Click()
   DeleteSetting "RegCust", "StartUp", "LastEntry"
End Sub
Private Sub cmdDelSection_Click()
   DeleteSetting "RegCust", "StartUp"
End Sub
Private Sub cmdUnInstall_Click()
   DeleteSetting "RegCust"
End Sub

4. How to open Password protected Access db?

'connection to secure database
Dim Cnn As ADODB.Connection
 
'In the place where you want to establish your connection, such 
'as the Initialize event of a class module, enter the following:
 
Dim strConnect As String
Set Cnn = New ADODB.Connection
 
'Substitute your own User IDs, Password, Data Source, and System
'database in the connection string below
    strConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Password=MyPassword;User ID=Administrator;" & _
        "Data Source=C:\AccessDBs\DB1.mdb;" & _
        "Persist Security Info=True;" & _
        "Jet OLEDB:System database=C:\AccessDBs\system.mdw"
 
'if you don't need you can eliminate the last line in connection string
 
    With Cnn
        .CursorLocation = adUseClient
        .Open strConnect
    End With

5. How to save image in db?
Have a look at this official FAQ article: Database - How can I store images (or other files) in a database?

6. How to write/read text file?

'write
Option Explicit
'Set a reference to Microsoft Scripting Runtime 
Private Sub Command1_Click()
    Dim fs As FileSystemObject
    Dim ts As TextStream
     
    Set fs = New FileSystemObject
    'To write
    Set ts = fs.OpenTextFile("C:\mytestfile.txt", ForWriting, True)
    ts.WriteLine "I Love"
    ts.WriteLine "VB Forums"
    ts.Close
     
    'To Read
    If fs.FileExists("C:\mytestfile.txt") Then
        Set ts = fs.OpenTextFile("C:\mytestfile.txt")
         
        Do While Not ts.AtEndOfStream
            MsgBox ts.ReadLine
        Loop
        ts.Close
    End If
    Set ts = Nothing
    Set fs = Nothing
End Sub
 
'read
Function FileText(ByVal filename As String) As String
    Dim handle As Integer
     
    ' ensure that the file exists
    If Len(Dir$(filename)) = 0 Then
        Err.Raise 53  ' File not found
    End If
     
    ' open in binary mode
    handle = FreeFile
    Open filename$ For Binary As #handle
    ' read the string and close the file
    FileText = Space$(LOF(handle))
    Get #handle, , FileText
    Close #handle
End Function

7. How to fix invalid characters in sql criteria?

Crit="Mark's"
strSQL = "SELECT * FROM MyTable WHERE ComField ='" & CleanText(Crit) & "'"
Public Function CleanText(strIn As String) As String
    On Error GoTo VBError
    Dim iAcnt As Long
    Dim strString As String
    Dim vLimit As Long
    vLimit = Len(strIn)
    For iAcnt = 1 To vLimit
        Select Case Asc(Mid$(strIn, iAcnt, 1))
        Case 10, 13
            strString = strString & Mid$(strIn, iAcnt, 1)
        Case 124
            strString = strString & "!"
        Case 39
            strString = strString & "''"
        Case 34
            strString = strString & """"
        Case Is < 32
            strString = strString & " "
        Case Is > 126
            strString = strString & " "
        Case Else
            strString = strString & Mid$(strIn, iAcnt, 1)
        End Select
    Next
    CleanText = strString
    CleanText = Trim$(CleanText)
Exit Function
VBError:
    MsgBox "VBError in Sub Parse_SQL_Text : " & Err.Number & " - " & Err.Description
    Resume Next
End Function

8. How to dynamically add controls?

Dim WithEvents vTextBox As TextBox
Set vTextBox = Controls.Add("vb.textbox", "DeeU")

[dee-u]

9. How to terminate a process?

Option Explicit
'on win2k you need the following:
Private Const PROCESS_TERMINATE = &H1
'On nt 9X the following could be enough:
Private Const PROCESS_ALL_ACCESS = &H1F0FFF
'in any case, let us use both...
Private Const MAX_PATH As Integer = 260
 
Private Type PROCESSENTRY32
  dwSize As Long
  cntUsage As Long
  th32ProcessID As Long
  th32DefaultHeapID As Long
  th32moduleID As Long
  cntThreads As Long
  th32ParentProcessID As Long
  pcPriClassBase As Long
  dwFlags As Long
  szExeFile As String * MAX_PATH
End Type
 
Private Declare Function CreateToolHelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal ApphProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
 
Public Function KillApp(myName As String) As Boolean
    Dim uProcess As PROCESSENTRY32
    Dim rProcessFound As Long
    Dim hSnapShot As Long
    Dim szExename As String
    Dim exitCode As Long
    Dim myProcess As Long
    Dim iFound As Integer
    
    On Error GoTo ErrHandler
    
    Const TH32CS_SNAPPROCESS As Long = 2&
    
    uProcess.dwSize = Len(uProcess)
    hSnapShot = CreateToolHelpSnapshot(TH32CS_SNAPPROCESS, 0&)
    rProcessFound = ProcessFirst(hSnapShot, uProcess)
    
    Do While rProcessFound
       iFound = InStr(1, uProcess.szExeFile, Chr(0)) - 1
       If iFound > 0 Then
           szExename = LCase$(Left$(uProcess.szExeFile, iFound))
        
           If Right$(szExename, Len(myName)) = LCase$(myName) Then
               
               myProcess = OpenProcess(PROCESS_ALL_ACCESS Or PROCESS_TERMINATE, False, uProcess.th32ProcessID)
               KillApp = TerminateProcess(myProcess, exitCode)
               Call CloseHandle(myProcess)
               
                
               'if you have only one, exit here:
               'Exit Function
               'if you think you may have more than one,
               'let this go on
           End If
           rProcessFound = ProcessNext(hSnapShot, uProcess)
       End If
    Loop
    Call CloseHandle(hSnapShot)
    Exit Function
ErrHandler:
    MsgBox Err.Description
End Function

10. How to allow only one instance of app?

'Sol. 1
'in sub main or from_load...
If App.PrevInstance = True Then
    MsgBox "Already running...."
    End
End If
 
'Sol. 2
Option Explicit
 
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Sub Main()
    Dim m_hWnd As Long
 
    'Change Form1 to your form Caption.
    m_hWnd = FindWindow(vbNullString, "Form1")
    If m_hWnd > 0 Then
        MsgBox "Program " & App.Title & " is already running..."
        Unload Form1
        Exit Sub
    End If
 
    'Change Form1 to your form name.
    Form1.Show
End Sub

11. How to correctly end app?

Dim frm as Form
For Each frm in Forms
  if frm.hWnd<> Me.hWnd then
    Unload frm
  End If
Next

12. How to delete a file?

'Sol. 1
Kill C:\Your_Folder\Yourfile.EXE
 
'Sol. 2
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
fso.Deletefile ("c:\windows\desktop\doc1.doc")
 
'Sol. 3 (Move to recycle bin)
Private Type SHFILEOPSTRUCT
    hWnd As Long
    wFunc As Long
    pFrom As String
    pToAs String
    fFlagsAs Integer
    fAborted As Boolean
    hNameMaps As Long
    sProgress As String
    End Type
    Private Const FO_DELETE = &H3
    Private Const FOF_ALLOWUNDO = &H40
 
 
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
 
' Delete a single file
lResult = ShellDelete("DELETE.ME")
' Delete several files
lResult = ShellDelete("DELETE.ME", "LOVE_LTR.DOC", "COVERUP.TXT")
 
 
Public Function ShellDelete(ParamArray vntFileName() As Variant) As Long
    Dim I As Integer
    Dim sFileNames As String
    Dim SHFileOp As SHFILEOPSTRUCT
 
 
    For I = LBound(vntFileName) To UBound(vntFileName)
        sFileNames = sFileNames & vntFileName(I) & vbNullChar
    Next
    sFileNames = sFileNames & vbNullChar
 
 
    With SHFileOp
        .wFunc = FO_DELETE
        .pFrom = sFileNames
        .fFlags = FOF_ALLOWUNDO
    End With
    ShellDelete = SHFileOperation(SHFileOp)
End Function

13. How to make a form always on top?

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 Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const HWND_TOPMOST = -1
 
SetWindowPos FormName.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE

14. Block keyboard and mouse (win98)

'Sol. 1
Private Declare Function BlockInput Lib "user32" (ByVal fBlock As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub Form_Activate()
 DoEvents
 'block the mouse and keyboard input
 BlockInput True
 'wait 10 seconds before unblocking it
 Sleep 10000
 'unblock the mouse and keyboard input
 BlockInput False
End Sub
 
'Sol. 2
private sub command1_click()
dim aa
aa=shell("rundll keyboard,disable") 'this line will disable the Keyboard
End Sub
 
private sub command2_click()
dim aa
aa=shell("RUNDLL MOUSE,DISABLE") 'this line will disable the Mouse
End Sub

15. How to disable the Close (X) button on form?

Option Explicit
 
Public Declare Function GetSystemMenu Lib "user32" _
    (ByVal hwnd As Long, _
     ByVal bRevert As Long) As Long
 
Public Declare Function RemoveMenu Lib "user32" _
    (ByVal hMenu As Long, _
     ByVal nPosition As Long, _
     ByVal wFlags As Long) As Long
 
Public Const MF_BYPOSITION = &H400&
 
 
Public Sub DisableCloseWindowButton(frm As Form)
 
    Dim hSysMenu As Long
 
    'Get the handle to this windows
    'system menu
    hSysMenu = GetSystemMenu(frm.hwnd, 0)
 
    'Remove the Close menu item
    'This will also disable the close button
    RemoveMenu hSysMenu, 6, MF_BYPOSITION
 
    'Lastly, we remove the seperator bar
    RemoveMenu hSysMenu, 5, MF_BYPOSITION
 
End Sub
'--end code block
Now call the DisableCloseWindowButton from your forms load event.
 
Private Sub Form_Load()
    DisableCloseWindowButton Me
End Sub

16. How to get IP?
http://www.vbforums.com/showthread.php?t=338329

17. How to Shell and wait?

Option Explicit
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Const INFINITE = -1&
Private Function shellAndWait(ByVal fileName As String) As Long
    Dim executionStatus As Long
    Dim processHandle As Long
    Dim returnValue As Long
    'Execute the application/file
    executionStatus = Shell(fileName, vbNormalFocus)
     
    'Get the Process Handle
    processHandle = OpenProcess(&H100000, True, executionStatus)
     
    'Wait till the application is finished
    returnValue = WaitForSingleObject(processHandle, INFINITE)
     
    'Send the Return Value Back
    shellAndWait = returnValue
End Function
 
Private Sub Command1_Click()
    'launch the application and wait
    Dim fileName As String
    Dim retrunValue As Long
     
     
    fileName = "EXCEL.EXE"
    retrunValue = shellAndWait(fileName)
     
    If retrunValue = 0 Then
        MsgBox "Application executed and was finished"
    End If
End Sub

18. How to deal with SysTray?
http://www.vbforums.com/showthread.p...hlight=systray

19. How to autocomplete combobox?

Option Explicit
public Const CB_FINDSTRING = &H14C
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
 
Function AutoComplete(cbCombo As ComboBox, sKeyAscii As Integer, Optional bUpperCase As Boolean = True) As Integer
    Dim lngFind As Long, intPos As Integer, intLength As Integer
    Dim tStr As String
    
    With cbCombo
        If sKeyAscii = 8 Then
            If .SelStart = 0 Then Exit Function
            .SelStart = .SelStart - 1
            .SelLength = 32000
            .SelText = ""
        Else
            intPos = .SelStart
            tStr = .Text
            If bUpperCase = True Then
                .SelText = UCase(Chr(sKeyAscii))
            Else
                .SelText = UCase(Chr(sKeyAscii))
            End If
        End If
        
        lngFind = SendMessage(.hwnd, CB_FINDSTRING, 0, ByVal .Text)
 
        If lngFind = -1 Then
            .Text = tStr
            .SelStart = intPos
            .SelLength = (Len(.Text) - intPos)
            AutoComplete = 0
            Exit Function
        Else
            intPos = .SelStart
            intLength = Len(.List(lngFind)) - Len(.Text)
            .SelText = .SelText & Right(.List(lngFind), intLength)
            .SelStart = intPos
            .SelLength = intLength
        End If
    End With
End Function

[sciguyryan]

20. How can I copy the contents of one listbox to another?

Dim I As Integer
For I = 0 To lstName1.Count
    lstName2.AddItem lstName1.List(I)
Next I

21. I get an error number 7 message when trying to run my program, why?

This is an error that states that you have run out of memory. See here for information on the possible causes and solutions.

22. How do I open a webpage in the defult browser?

Simple, use the ShellExecute API Call as shows below

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
 
Private Sub OpenURL(strURL As String)
    ShellExecute Me.hWnd, "open", strURL, vbNullString, "C:\", ByVal 1&
    ' Change the last perameter to 0& if you do not whant to show the window.
End Sub

Just call the OpenURL sub with the URL of the webpage to open as its perameter.


23. How do I open a file type with its default application?

Again, use the ShellExecute AI function.

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
 
Private Sub OpenAFile(strFileLocation As String)
    If Dir$(strFileLocation) = "" Then
        Exit Sub
    End If
    ShellExecute Me.hWnd, "open", strURL, vbNullString, "C:\", ByVal 1&
    ' Change the last perameter to 0& if you do not whant to show the window.
End Sub

Just call the OpenAFile sub with the path of the file to open as its perameter.

24. How can I check if a file exists?

Private Function CheckPath(strPath As String) As Boolean
    If Dir$(strPath) <> "" Then
        CheckPath = True
    Else
        CheckPath = False
    End If
End Function

Just call the above function with the path of the file to check as its perameter

25. How do I create a "browse for folder" dialog box?

Use this Module kindly provided by manavo11.

26. How do I make my application start up with Windows?

Have a look at this thread, a good example was posted there.

26. How do I shutdown / restart / logoff a computer?

Again an API call holds the answer:

Private Const EWX_LOGOFF = 0
Private Const EWX_SHUTDOWN = 1
Private Const EWX_REBOOT = 2
Private Const EWX_FORCE = 4
Private Declare Function ExitWindowsEx Lib "user32.dll" ( _ 
    ByVal uFlags As Long, _ 
    ByVal dwReserved As Long) As Long

To Shutdown Windows call this:

Call ExitWindowsEx(EWX_SHUTDOWN, 0)

To Restart Windows call this:

Call ExitWindowsEx(EWX_REBOOT, 0)

To logoff Windows call this:

Call ExitWindowsEx(EWX_LOGOFF, 0)

27. How do I create a form that is not square shaped?

Have a lok at this thread. Some useful links were posted there.

Cheers,

RyanJ

[sciguyryan]

28. What does the $ notation after a variable name mean?

Those were the old-BASIC style for declaring variables that are not often used anymore. The full list is included below.

String: $
Integer: %
Long: &
Single: !
Double: #
Currency: @

29. How do i get the hard disk ID number?

Private Function DriveSerial(strDrive As String) As String
    ' Returns the drive serial number.
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If Len(strDrive) > 3 Then
        Exit Sub
    End If
    If (FSO.GetDrive(strDrive).IsReady = True) And (Not GetDriveType(strDrive) = 5) Then
        DriveSerial = CStr(FSO.GetDrive(strDrive).SerialNumber)
    Else
        DriveSerial = "Not Available"
    End If
End Property

30. How can I get a list of all the fonts installed on the system?

VB has a built in array of these as part of the Screen object, it is called:

Screen.Fonts

31. Howcan I tell if Internet Explorer is running?

Use the following function.

Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _ 
    ByVal lpClassName As String, _ 
    ByVal lpWindowName As String) As Long
 
 
Private Function IsIERunning() As Boolean
    Dim lngRet As Long
    lngRet = FindWindow("IEFrame", vbNullString)
    If lngRet <> 0 Then
        IsIERunning = True
    Else
        IsIERunning = False
    End If
End Function

Just call the IsIERunning function, it will return a boolean value representing if it is, or if not running

Cheers,

RyanJ

[dee-u]

32. How to pause computer?

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub PauseComputer(byval vMSec as long)
    Sleep vMSec
End Sub

33. How to seek in a file?

private Function GetLastLine(byval FileName as string) as string
    Dim iFile as Integer
    Dim lFileLen as Long
    Dim sBuffer as string
    Dim iPos as Integer
'
' You might need to play with the offset depending on how big
' your 'lines' usually are in the file
'
    Const OFFSET as Long = 160
'
' The line delimiter string - in this case I'm using VBCRLF, it
' could just be LF in some cases, again, be careful
'
    Const FINDSTR as string = vbCrLf
'
    iFile = FreeFile
    sBuffer = Space$(OFFSET)
'
    Open FileName for binary Access Read as #iFile
    seek #iFile, (LOF(iFile) - OFFSET)
    get #iFile, , sBuffer
    Close #iFile
'
    iPos = InStrRev(sBuffer, FINDSTR)
    If iPos = 0 then
        GetLastLine = sBuffer
    else
        GetLastLine = mid$(sBuffer, iPos + len(FINDSTR))
    End If
'
End Function

34. How to get computer name?

Private Const MAX_COMPUTERNAME_LENGTH As Long = 31
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Sub Form_Load()
 Dim dwLen As Long
 Dim strString As String
 'Create a buffer
 dwLen = MAX_COMPUTERNAME_LENGTH + 1
 strString = String(dwLen, "X")
 'Get the computer name
 GetComputerName strString, dwLen
 'get only the actual data
 strString = Left(strString, dwLen)
 'Show the computer name
 MsgBox strString
End Sub

35. How to create shortcut?

'Sol. 1
'add a reference to Windows Script Host Model
Dim WshShell As New WshShell
    Dim oShellLink As WshShortcut
     
    'Create and save the shortcut
    'Here, it is important the the extension end by .lnk
    Set oShellLink = WshShell.CreateShortcut( "C:\TestLink.lnk" )
    With oShellLink
 
    'Shortcut to which file (can be anything, .exe, .doc, ...)
        .TargetPath = "C:\WINNT\SYSTEM32\calc.exe"
        .WindowStyle = 1
        .IconLocation = "C:\WINNT\SYSTEM32\calc.exe, 0"
        .Arguments = ""
        .Save
    End With
     
    Set WshShell = Nothing
    Set oShellLink = Nothing
 
'Sol. 2
Sub CreateShortCut(File As String, icon As String, iconindex As Long, Target As String)
    Dim intFreeFile As Integer
    File = File & ".url"
    intFreeFile = FreeFile
    Open File For Output As intFreeFile
    Print #intFreeFile, "[InternetShortcut]"
    Print #intFreeFile, "URL=" & Target
    Print #intFreeFile, "IconFile=" & icon
    Print #intFreeFile, "Iconindex=" & iconindex
    Close intFreeFile
End Sub
 
CreateShortCut "File","icon","0","c:"

36. How to close an application?

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Const WM_CLOSE = &H10
Private Sub Form_Load()
Dim winHwnd As Long
Dim RetVal As Long
winHwnd = FindWindow(vbNullString, "Calculator")
If winHwnd <> 0 Then
PostMessage winHwnd, WM_CLOSE, 0&, 0&
Else
MsgBox "The Calculator is not open."
End If
End Sub

37. How to make a from transparent?

Public Const GWL_EXSTYLE = (-20)
Public Const WS_EX_TRANSPARENT = &H20&
Public Const SWP_FRAMECHANGED = &H20
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Public Const SWP_SHOWME = SWP_FRAMECHANGED Or _
SWP_NOMOVE Or SWP_NOSIZE
Public Const HWND_NOTOPMOST = -2   
 
 Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
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   
 
'Add a commandbutton with following code to Form1
 
Private Sub Command1_Click()
SetWindowLong Me.hwnd, GWL_EXSTYLE, _
WS_EX_TRANSPARENT
SetWindowPos Me.hwnd, HWND_NOTOPMOST, _
0&, 0&, 0&, 0&, SWP_SHOWME
End Sub   
 
' The ShowInTaskbar property should be set to False and the BorderStyle to 0-None.

38. How to create a hotkey?

'Module Code
 
Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Long) As Long
 
Declare Function DefWindowProc Lib "user32" _
Alias "DefWindowProcA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
 
Public Const WM_SETHOTKEY = &H32
Public Const WM_SHOWWINDOW = &H18
Public Const HK_SHIFTA = &H141 'Shift + A
Public Const HK_SHIFTB = &H142 'Shift * B
Public Const HK_CONTROLA = &H241 'Control + A
Public Const HK_ALTZ = &H45A
 
'The value of the key-combination has to
'declared in lowbyte/highbyte-format
 
'That means as a hex-number: the last two
'characters specify the lowbyte (e.g.: 41 = a),
'the first the highbyte (e.g.: 01 = 1 = Shift)
 
'Form Code
 
Private Sub Form_Load()
Me.WindowState = vbMinimized
'Let windows know what hotkey you want for
'your app, setting of lParam has no effect
erg& = SendMessage(Me.hwnd, WM_SETHOTKEY, _
HK_ALTZ, 0)
'Check if succesfull
If erg& <> 1 Then
MsgBox "You need another hotkey", vbOKOnly, _
"Error"
End If
 
'Tell windows what it should do, when the hotkey
'is pressed -> show the window!
'The setting of wParam and lParam has no effect
 
erg& = DefWindowProc(Me.hwnd, WM_SHOWWINDOW, _
0, 0)
End Sub
 
'When the user presses ALT+Z Form1 is shown.

[sciguyryan]

39. How do I get the current logged in username?

Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" ( _
    ByVal lpBuffer As String, _
    nSize As Long) As Long
 
Private Function UserName() As String
    Dim strBuffer As String
    Dim lngSize As Long
    strBuffer = Space$(255)
    lngSize = Len(strBuffer)
    Call GetUserName(strBuffer, lngSize)
    UserName = Left$(strBuffer, lngSize)
End Function

Simple call the UserName() function :)

40. How can I make it so a compoents can be dragged around the screen?

Use the following code, changing Object to the components name.

' These are global variables! Put them at the top of your form.
Dim intX As Integer
Dim intY As Integer
 
Private Sub Object_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton Then
        intX = X
        intY = Y
        Object.MousePointer = vbSizeAll
    End If
End Sub
 
Private Sub Object_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton Then
        Object.Left = (Object.Left - intX) + X
        Object.Top = (Object.Top - intY) + Y
    End If
End Sub
 
Private Sub Object_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Object.MousePointer = vbDefault
End Sub

41. How can I add music to my exe?

Use the mciSendString API function. This can play MIDI, MP3, and WAV files. :)

42. How do I create a random number between xxx and xxx?

Use the following function.

Private Function MakeRandom(intLowest As Integer, intHighest As integer) As Long
    Ramdomize
    Dim intTemp As Integer
    If intLowest > intHighest Then
        intTemp = intLowest
        intLowest = intHighest
        intHighest = intTemp
    End If
    MakeRandom = CLng((intHighest - intLowest + 1) * Rnd + intLowest)
End Function

43. How do I add multiple patterns to the Pattern property of a FileListBox?

Quite simple, just seperate all the file types with a semi-colon (;).
E.G. If you wanted to show all DLL and all OCX files then you would do the following:

filFileListboxName.Pattern = "*.dll;*.ocx"

44. How do I zip / un-zip files using VB?

Have a look here - that is a good example of how it can be done.

Cheers,

RyanJ

[moeur]

45. How do I scroll to the bottom of a multi-line textbox?

Text1.SelStart = Len(Text1)

46. How do I get the number of lines in a text file?

Function NumLines(FileName As String) As Long
Dim ff As Integer
Dim strBuff As String
Dim str() As String
  ff = FreeFile
  Open FileName For Input As #ff
  strBuff = Input(LOF(ff), ff)
  Close #ff
  str() = Split(strBuff, vbCrLf)
  NumLines = UBound(str) - LBound(str) + 1
End Function

[dee-u]

47. How to clear all textboxes in a form?

Public Sub ClearTextBoxes(frmClearMe As Form)
 
 Dim txt As Control
 
'clear the text boxes
 For Each txt In frmClearMe
 
  If TypeOf txt Is TextBox Then txt.Text = ""
 
 Next
 
End Sub

48. How to cut,copy and paste in MSFlexGrid?

Private Sub EditCut()
    'Cut the selection and put it on the Clipboard
    EditCopy
    EditDelete
End Sub
 
Private Sub EditCopy()
    'Copy the selection and put it on the Clipboard
    Clipboard.Clear
    Clipboard.SetText MSFlexGrid1.Clip
End Sub
 
Private Sub EditPaste()
    'Insert Clipboard contents
    If Len(Clipboard.GetText) Then MSFlexGrid1.Clip = _
         Clipboard.GetText
End Sub
 
Private Sub EditDelete()
    'Deletes the selection
    Dim i As Integer
    Dim j As Integer
    Dim strClip As String
    With MSFlexGrid1
        For i = 1 To .RowSel
            For j = 1 To .ColSel
                strClip = strClip & "" & vbTab
            Next
            strClip = strClip & vbCr
        Next
        .Clip = strClip
    End With
End Sub
 
Private Sub EditSelectAll()
    'Selects the whole Grid
    With MSFlexGrid1
        .Visible = False
        .row = 1
        .col = 1
        .RowSel = .Rows - 1
        .ColSel = .Cols - 1
        .TopRow = 1
        .Visible = True
    End With
End Sub

49. How to search a listbox?

Option Explicit
Private Declare Function SendMessage Lib "User32" _
Alias "SendMessageA" (ByVal hWnd As Long, ByVal _
wMsg As Integer, ByVal wParam As Integer, lParam _
As Any) As Long
Const LB_FINDSTRING = &H18F
 
Private Sub Form_Load()
With List1
.Clear
.AddItem "CPU"
.AddItem "RAM"
.AddItem "ROM"
.AddItem "Cache"
.AddItem "Motherboard"
.AddItem "Hard Disk"
.AddItem "Floppy Disk"
End With
End Sub
 
Private Sub Text1_Change()
List1.ListIndex = SendMessage(List1.hWnd, LB_FINDSTRING, -1, ByVal
Text1.Text)
Text1.Text = List1.Text
End Sub

50. How to search and highlight string in textbox?

Public Function searchHighlight(srchTextBox As textBox, srchString As String)
    On Error Resume Next
    Dim A As Integer
    Call srchTextBox.SetFocus
    SendKeys ("^{HOME}")
    A = 1
 
 
    Do Until A = Len(srchTextBox.text)
        'if word was found...
 
 
        If Mid$(UCase$(srchTextBox.text), A, Len(srchString)) = UCase$(srchString) Then
            'highlight the word
 
 
            For A = 1 To Len(srchString)
                SendKeys ("+{RIGHT}")
            Next A
            Exit Do
        End If
        'if word isnt found or a return is found
        '     , dont do anything
 
 
        If Mid(srchTextBox.text, A, 1) = Chr$(13) Then
        Else
            'go to next line
            SendKeys ("{RIGHT}")
        End If
        A = A + 1
        If A > Len(srchTextBox.text) Then Exit Do
    Loop
End Function

51. How to make the title bar flash?

Private Declare Function FlashWindow _
Lib "user32" (ByVal hwnd As Long, _
ByVal bInvert As Long) As Long
 
Private Sub tmrFlash_Timer()
 
Dim lngRet As Long
'// Flash the window
lngRet = FlashWindow(Me.hwnd, 1)
End Sub
 
Private Sub cmdFlash_Click()
'// Flash every 0.5 seconds
tmrFlash.Interval = 500
tmrFlash.Enabled = True
End Sub
 
Private Sub Form_Load()
'// Don't start flashing yet
tmrFlash.Enabled = False
End Sub

52. How to find out how long Windows has been running?

Declare Function GetTickCount& Lib "kernel32" ()
 
Private Sub cmdWinRun_Click()
MsgBox GetTickCount
End Sub

53. How to compact Access database using ado?

Public Sub CompactDB()
    'Microsoft Jet and Replication objects
    Dim objJE As New JRO.JetEngine, strSource As String, strTarget As String
    DoEvents
    Busy True
    strSource = "  "
    strTarget = " "    
objJE.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strSource & ";", "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strTarget & ";Jet OLEDB:Engine Type=4;"
    Busy False
    'Engine type:
    'Access 97 = 4
    'Access 2000 = 5
End Sub

54. How to determine if app is running in IDE?

Public Function IsIDE() As Boolean
    On Error GoTo ErrHandler
    'because debug statements are ignored when
    'the app is compiled, the next statment will
    'never be executed in the EXE.
    Debug.Print 1 / 0
    IsIDE = False
Exit Function
ErrHandler:
    'If we get an error then we are
    'running in IDE / Debug mode
    IsIDE = True
End Function

[sciguyryan]

55. How can I use command line perameters in my program

Command line parameters are automatically assigned to a string variable called Command$.

I would suggest the use of something like the following: (Assuming you have used a space to seperate each parameter)

Dim strParameters() As String
strParameters = Split(Command$, " ")
 
Select Case strParameters(0)
    Case "inimake"
        ' Do soemthing here
    Case Else
        ' Do something else here.
End Select

Of corse you'll need to add error checking and the such

56. How can I check is my application is minamized?

Quite simple:

If Me.WindowState = vbMinimized Then
    ' Your program is minimized
End If

57. How can I find the number of the lowest and highest element in an array?

To find the lowest element number you can use the LBound function.

To find the last element number in the array you can use the UBound function.

58. How can I disable the "X" Minamize and Maxamize buttons in a MID form?

Have a look here. That link contains all the information you will need.

59. How can I disable Ctrl + Alt + Delete? How can I send Ctrl + Alt + Delete using the SendKeys function?

There are no shure ways to do these. Some will only work in Windows 98 and then it does not work all the time so to put it simply just take it that you cannot do the above tasks.

Cheers,

RyanJ

[penagate]

60. How to get the correct path of a special folder (e.g. My Documents, Program Files)

 Const CSIDL_DESKTOP                    As Long = &H0
 Const CSIDL_INTERNET                   As Long = &H1
 Const CSIDL_PROGRAMS                   As Long = &H2
 Const CSIDL_CONTROLS                   As Long = &H3
 Const CSIDL_PRINTERS                   As Long = &H4
 Const CSIDL_PERSONAL                   As Long = &H5
 Const CSIDL_FAVORITES                  As Long = &H6
 Const CSIDL_STARTUP                    As Long = &H7
 Const CSIDL_RECENT                     As Long = &H8
 Const CSIDL_SENDTO                     As Long = &H9
 Const CSIDL_BITBUCKET                  As Long = &HA
 Const CSIDL_STARTMENU                  As Long = &HB
 Const CSIDL_MYDOCUMENTS                As Long = &HC
 Const CSIDL_MYMUSIC                    As Long = &HD
 Const CSIDL_MYVIDEO                    As Long = &HE
 Const CSIDL_DESKTOPDIRECTORY           As Long = &H10
 Const CSIDL_DRIVES                     As Long = &H11
 Const CSIDL_NETWORK                    As Long = &H12
 Const CSIDL_NETHOOD                    As Long = &H13
 Const CSIDL_FONTS                      As Long = &H14
 Const CSIDL_TEMPLATES                  As Long = &H15
 Const CSIDL_COMMON_STARTMENU           As Long = &H16
 Const CSIDL_COMMON_PROGRAMS            As Long = &H17
 Const CSIDL_COMMON_STARTUP             As Long = &H18
 Const CSIDL_COMMON_DESKTOPDIRECTORY    As Long = &H19
 Const CSIDL_APPDATA                    As Long = &H1A
 Const CSIDL_PRINTHOOD                  As Long = &H1B
 Const CSIDL_LOCAL_APPDATA              As Long = &H1C
 Const CSIDL_ALTSTARTUP                 As Long = &H1D
 Const CSIDL_COMMON_ALTSTARTUP          As Long = &H1E

 Const CSIDL_COMMON_FAVORITES           As Long = &H1F
 Const CSIDL_INTERNET_CACHE             As Long = &H20
 Const CSIDL_COOKIES                    As Long = &H21
 Const CSIDL_HISTORY                    As Long = &H22
 Const CSIDL_COMMON_APPDATA             As Long = &H23
 Const CSIDL_WINDOWS                    As Long = &H24
 Const CSIDL_SYSTEM                     As Long = &H25
 Const CSIDL_PROGRAM_FILES              As Long = &H26
 Const CSIDL_MYPICTURES                 As Long = &H27
 Const CSIDL_PROFILE                    As Long = &H28
 Const CSIDL_PROGRAM_FILES_COMMON       As Long = &H2B
 Const CSIDL_COMMON_TEMPLATES           As Long = &H2D
 Const CSIDL_COMMON_DOCUMENTS           As Long = &H2E
 Const CSIDL_COMMON_ADMINTOOLS          As Long = &H2F
 Const CSIDL_ADMINTOOLS                 As Long = &H30
 Const CSIDL_CONNECTIONS                As Long = &H31
 Const CSIDL_COMMON_MUSIC               As Long = &H35
 Const CSIDL_COMMON_PICTURES            As Long = &H36
 Const CSIDL_COMMON_VIDEO               As Long = &H37
 Const CSIDL_RESOURCES                  As Long = &H38
 Const CSIDL_RESOURCES_LOCALIZED        As Long = &H39
 Const CSIDL_COMMON_OEM_LINKS           As Long = &H3A
 Const CSIDL_CDBURN_AREA                As Long = &H3B
 Const CSIDL_COMPUTERSNEARME            As Long = &H3D
 
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
    (ByVal pidl As Long, _
     ByVal pszPath As String) _
    As Long
    
Public Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _
    (ByVal hwndOwner As Long, _
     ByVal nFolder As Long, _
     ByRef pidl As Long) _
    As Long
 
 Public Function GetSpecialFolder(ByVal CSIDL As Long) As String
    Dim pidl    As Long
    Dim strPath As String
    dim lngPos  As Long
    
    Dim csidltopidl As Long
    
    If (csidl) Then
        If SHGetSpecialFolderLocation(frmRef.hWnd, csidl, pidl) = 0 Then _
            csidltopidl = pidl
      Else
        csidltopidl = 0&
    End If
    
    strPath = Space$(260)
    
    If SHGetPathFromIDList(ByVal pidl, ByVal strPath) Then
        lngPos = InStr(strPath, Chr$(0))
        If (lngPos) Then _
            GetSpecialWinFolder = Left$(strPath, lngPos - 1)
   End If
End Function

61. a) Get the hWnd of a combo box's edit portion

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
    (ByVal hWndParent As Long, _
     ByVal hWndChildAfter As Long, _
     ByVal lpszClass As String, _
     ByVal lpszTitle As String) _
    As Long

Public Function GetComboBoxEdithWnd(ByVal hWnd As Long) As Long
   GetComboBoxEdithWnd = FindWindowEx(hWnd, 0, "EDIT", vbNullString)
End Function

in order to...

b) Add Windows' URL and file path auto-completion to a textbox or combo box

Private Declare Function SHAutoComplete Lib "shlwapi.dll" _
    (ByVal hWndEdit As Long, _
     ByVal dwFlags As Long) _
    As Long

Public Enum SHAutoCompleteFlags
   SHACF_DEFAULT = &H0
   SHACF_FILESYSTEM = &H1
   SHACF_URLHISTORY = &H2
   SHACF_URLMRU = &H4
   SHACF_USETAB = &H8
   SHACF_URLALL = (SHACF_URLHISTORY Or SHACF_URLMRU)
   SHACF_FILESYS_ONLY = &H10
   SHACF_FILESYS_DIRS = &H20
   SHACF_AUTOSUGGEST_FORCE_ON = &H10000000
   SHACF_AUTOSUGGEST_FORCE_OFF = &H20000000
   SHACF_AUTOAPPEND_FORCE_ON = &H40000000
   SHACF_AUTOAPPEND_FORCE_OFF = &H80000000
End Enum

Public Function AutoComplete(ByVal hWnd As Long, _
                             ByVal penmFlags As SHAutoCompleteFlags) _
                            As Long
    AutoComplete = (SHAutoComplete(hWnd, penmFlags))
End Function

Edit: Left out a couple of API declares, thanks CVMichael

[CVMichael]

Dee-u, I like your code, but I have a problem with point 50.
I would not trust "SendKeys" since it sends the keys on window(control) that curently selected, even if you select it first, you don't know for sure that maybe another app may change the selection right after that...
Also, checking character by character is a slow process.

Anyways, I think this is better:
50. How to search and highlight string in textbox?

Public Sub searchHighlight(srchTextBox As TextBox, srchString As String)
    Dim Pos As Long
    
    Pos = InStr(1, srchTextBox.Text, srchString, vbTextCompare)
    
    If Pos > 0 Then
        srchTextBox.SetFocus
        
        srchTextBox.SelStart = Pos - 1
        srchTextBox.SelLength = Len(srchString)
    End If
End Sub

[moeur]

62. How can I do high-resolution timing?

Define these functions

Option Explicit
 
Private Declare Function QueryPerformanceCounter Lib "Kernel32" _
                                 (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" _
                                 (X As Currency) As Boolean
 
Private Type TimerData
    StartCount As Currency
    StopCount As Currency
    Overhead As Currency
    Frequency As Currency
End Type
 
'returns the number of seconds elapsed between StopCount and StartCount
'Assumes that InitPerformanceTimer has been called
Private Function ElapsedTime(MyData As TimerData) As Single
 With MyData
    ElapsedTime = (.StopCount - .StartCount - .Overhead) / .Frequency 'seconds
 End With
End Function
 
'Initializes the data structure so that the ElapsedTime function can be called
'Returns false if the High-resolution timer is not supported
Private Function InitPerformanceTimer(MyData As TimerData) As Boolean
    Dim Ctr1 As Currency, Ctr2 As Currency
    With MyData
      If QueryPerformanceCounter(Ctr1) Then
          QueryPerformanceCounter Ctr2
          QueryPerformanceFrequency .Frequency
          '1/Freq*10000 is resolution of timer in seconds
          Debug.Print "QueryPerformanceCounter minimum resolution: 1/" & _
                      .Frequency * 10000; " seconds"
          'This overhead is present for each call to API
          .Overhead = Ctr2 - Ctr1
          Debug.Print "API Overhead: "; .Overhead / .Frequency; "seconds"
          InitPerformanceTimer = True
        Else
          Debug.Print "High-resolution counter not supported."
          InitPerformanceTimer = False
        End If
    End With
End Function

Use it like this

Private Sub Command1_Click()
    Dim MyData As TimerData
    Dim i As Integer, b As Integer
    If Not InitPerformanceTimer(MyData) Then
        'sorry, no can do
        MsgBox "High-resolution counter not supported"
        Exit Sub
    Else
        With MyData
            b = 0
            'get start time
            QueryPerformanceCounter .StartCount
            'perform some task you want to time
            For i = 1 To 100
                b = b + i
            Next i
            'get stop time
            QueryPerformanceCounter .StopCount
            'get elapsed time
            MsgBox "Elapsed time is " & CStr(ElapsedTime(MyData) * 1000) & " milliseconds."
        End With
    End If
End Sub

63. How do I get a String from a long pointer?
This question comes up when trying to use certain API functions, and when processing certain Windows messages.
There are two cases to consider.

1. You "own" the string buffer that the pointer points to.
In this case you just need to provide the buffer space and modify the string a little once it's been returned.
Here is an example that gets a window caption.

Option Explicit
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
 
Private Function GetText(TargethWnd As Long) As String
Dim lpString As String
Dim maxStr As Long
    maxStr = 100
    lpString = Space(maxStr)
    If GetWindowText(TargethWnd, lpString, maxStr) = 0 Then
        MsgBox "GetWindowText failed"
        GetText = ""
    Else
        GetText = Left(lpString, InStr(lpString, Chr(0)) - 1)
    End If
End Function

2. The second case is one where the OS "owns" the buffer and you must copy the string data into a VB String variable.
This example gets string data that is pointed to by a long pointer inside the CopyData Structure.
If you have the declarations

Option Explicit
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
 
Private Type COPYDATASTRUCT
        dwData As Long
        cbData As Long
        lpData As Long
End Type
Dim MyData As COPYDATASTRUCT
Dim X As String

Then you can get the data using this function

'This function returns the string pointed to by pstr
'strCNT is the number of characters in the string
'strings from dlls are terminated with a null character
Function StrFromPtr(pStr As Long, Optional strCNT As Long = 256) As String
 Dim bTemp As Byte
 Dim i As Long
 Dim X As String
 X = ""
 For i = 0& To strCNT - 1
   CopyMemory bTemp, ByVal pStr + i, 1
   'convert LF to CR & LF
   If bTemp = 10 Then
     X = X & vbCrLf
   Else
     X = X & Chr(bTemp)
   End If
 Next i
 StrFromPtr = X
End Function

Using it like so:

X = StrFromPtr(MyData.lpData, MyData.cbData)

64. How do I do video Capture from VB?
Check out this excellent port of Vidcap32 to VB
http://www.shrinkwrapvb.com/vbvidcap.htm

[Megatron]

You might want to edit your first post to include a table on contents.

[sciguyryan]

63. How do I load a Word / Excel file using VB without using Shell, ShellExecute or, without adding an office reference to my project?

Use the following code:

Word:

Dim wdWord As Object
Dim wdDocument As Object
Set wdWord = CreateObject("Word.Application")
Set wdDocument = CreateObject("Word.Document")
Set wdDocument = wdWord.Documents.Open("Path_To_Some_File_Here.doc")

Excel:

Dim exExcel As Object
Set exExcel = CreateObject("Excel.Application")
exExcel.Workbooks.Open ("Path_To_Some_File_Here.xls")
exExcel.Visible = True

Cheers,

RyanJ

[MartinLiss]

9. How to terminate a process?

Option Explicit
'on win2k you need the following:
Private Const PROCESS_TERMINATE = &H1
'On nt 9X the following could be enough:
Private Const PROCESS_ALL_ACCESS = &H1F0FFF
'in any case, let us use both...
Private Const MAX_PATH As Integer = 260
 
Private Type PROCESSENTRY32
  dwSize As Long
  cntUsage As Long
  th32ProcessID As Long
  th32DefaultHeapID As Long
  th32moduleID As Long
  cntThreads As Long
  th32ParentProcessID As Long
  pcPriClassBase As Long
  dwFlags As Long
  szExeFile As String * MAX_PATH
End Type
 
Private Declare Function CreateToolHelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal ApphProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
 
Public Function KillApp(myName As String) As Boolean
    Dim uProcess As PROCESSENTRY32
    Dim rProcessFound As Long
    Dim hSnapShot As Long
    Dim szExename As String
    Dim exitCode As Long
    Dim myProcess As Long
    Dim iFound As Integer
    
    On Error GoTo ErrHandler
    
    Const TH32CS_SNAPPROCESS As Long = 2&
    
    uProcess.dwSize = Len(uProcess)
    hSnapShot = CreateToolHelpSnapshot(TH32CS_SNAPPROCESS, 0&)
    rProcessFound = ProcessFirst(hSnapShot, uProcess)
    
    Do While rProcessFound
       iFound = InStr(1, uProcess.szExeFile, Chr(0)) - 1
       If iFound > 0 Then
           szExename = LCase$(Left$(uProcess.szExeFile, iFound))
        
           If Right$(szExename, Len(myName)) = LCase$(myName) Then
               
               myProcess = OpenProcess(PROCESS_ALL_ACCESS Or PROCESS_TERMINATE, False, uProcess.th32ProcessID)
               KillApp = TerminateProcess(myProcess, exitCode)
               Call CloseHandle(myProcess)
               
                
               'if you have only one, exit here:
               'Exit Function
               'if you think you may have more than one,
               'let this go on
           End If
           rProcessFound = ProcessNext(hSnapShot, uProcess)
       End If
    Loop
    Call CloseHandle(hSnapShot)
    Exit Function
ErrHandler:
    MsgBox Err.Description
End Function

10. How to allow only one instance of app?

'Sol. 1
'in sub main or from_load...
If App.PrevInstance = True Then
    MsgBox "Already running...."
    End
End If
 
'Sol. 2
Option Explicit
 
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Sub Main()
    Dim m_hWnd As Long
 
    'Change Form1 to your form Caption.
    m_hWnd = FindWindow(vbNullString, "Form1")
    If m_hWnd > 0 Then
        MsgBox "Program " & App.Title & " is already running..."
        Unload Form1
        Exit Sub
    End If
 
    'Change Form1 to your form name.
    Form1.Show
End Sub

11. How to correctly end app?

Dim frm as Form
For Each frm in Forms
  if frm.hWnd<> Me.hWnd then
    Unload frm
  End If
Next

12. How to delete a file?

'Sol. 1
Kill C:\Your_Folder\Yourfile.EXE
 
'Sol. 2
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
fso.Deletefile ("c:\windows\desktop\doc1.doc")
 
'Sol. 3 (Move to recycle bin)
Private Type SHFILEOPSTRUCT
    hWnd As Long
    wFunc As Long
    pFrom As String
    pToAs String
    fFlagsAs Integer
    fAborted As Boolean
    hNameMaps As Long
    sProgress As String
    End Type
    Private Const FO_DELETE = &H3
    Private Const FOF_ALLOWUNDO = &H40
 
 
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
 
' Delete a single file
lResult = ShellDelete("DELETE.ME")
' Delete several files
lResult = ShellDelete("DELETE.ME", "LOVE_LTR.DOC", "COVERUP.TXT")
 
 
Public Function ShellDelete(ParamArray vntFileName() As Variant) As Long
    Dim I As Integer
    Dim sFileNames As String
    Dim SHFileOp As SHFILEOPSTRUCT
 
 
    For I = LBound(vntFileName) To UBound(vntFileName)
        sFileNames = sFileNames & vntFileName(I) & vbNullChar
    Next
    sFileNames = sFileNames & vbNullChar
 
 
    With SHFileOp
        .wFunc = FO_DELETE
        .pFrom = sFileNames
        .fFlags = FOF_ALLOWUNDO
    End With
    ShellDelete = SHFileOperation(SHFileOp)
End Function

13. How to make a form always on top?

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 Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const HWND_TOPMOST = -1
 
SetWindowPos FormName.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE

14. Block keyboard and mouse (win98)

'Sol. 1
Private Declare Function BlockInput Lib "user32" (ByVal fBlock As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub Form_Activate()
 DoEvents
 'block the mouse and keyboard input
 BlockInput True
 'wait 10 seconds before unblocking it
 Sleep 10000
 'unblock the mouse and keyboard input
 BlockInput False
End Sub
 
'Sol. 2
private sub command1_click()
dim aa
aa=shell("rundll keyboard,disable") 'this line will disable the Keyboard
End Sub
 
private sub command2_click()
dim aa
aa=shell("RUNDLL MOUSE,DISABLE") 'this line will disable the Mouse
End Sub

15. How to disable the Close (X) button on form?

Option Explicit
 
Public Declare Function GetSystemMenu Lib "user32" _
    (ByVal hwnd As Long, _
     ByVal bRevert As Long) As Long
 
Public Declare Function RemoveMenu Lib "user32" _
    (ByVal hMenu As Long, _
     ByVal nPosition As Long, _
     ByVal wFlags As Long) As Long
 
Public Const MF_BYPOSITION = &H400&
 
 
Public Sub DisableCloseWindowButton(frm As Form)
 
    Dim hSysMenu As Long
 
    'Get the handle to this windows
    'system menu
    hSysMenu = GetSystemMenu(frm.hwnd, 0)
 
    'Remove the Close menu item
    'This will also disable the close button
    RemoveMenu hSysMenu, 6, MF_BYPOSITION
 
    'Lastly, we remove the seperator bar
    RemoveMenu hSysMenu, 5, MF_BYPOSITION
 
End Sub
'--end code block
Now call the DisableCloseWindowButton from your forms load event.
 
Private Sub Form_Load()
    DisableCloseWindowButton Me
End Sub

16. How to get IP?
http://www.vbforums.com/showthread.php?t=338329

17. How to Shell and wait?

Option Explicit
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Const INFINITE = -1&
Private Function shellAndWait(ByVal fileName As String) As Long
    Dim executionStatus As Long
    Dim processHandle As Long
    Dim returnValue As Long
    'Execute the application/file
    executionStatus = Shell(fileName, vbNormalFocus)
     
    'Get the Process Handle
    processHandle = OpenProcess(&H100000, True, executionStatus)
     
    'Wait till the application is finished
    returnValue = WaitForSingleObject(processHandle, INFINITE)
     
    'Send the Return Value Back
    shellAndWait = returnValue
End Function
 
Private Sub Command1_Click()
    'launch the application and wait
    Dim fileName As String
    Dim retrunValue As Long
     
     
    fileName = "EXCEL.EXE"
    retrunValue = shellAndWait(fileName)
     
    If retrunValue = 0 Then
        MsgBox "Application executed and was finished"
    End If
End Sub

18. How to deal with SysTray?
http://www.vbforums.com/showthread.p...hlight=systray

[B]19. ...[/Highlight]

In Number 12, you should check for the possibility of the user Canceling the dialog. You do that by looking at If FileOperation.fAnyOperationsAborted which will be True in that case.

[body-korkis]

Thank you

[RobDog888]

Most of this stuff is already in the API FAQ or other FAQs.

[pyrojoker03]

are all this codes available in VB 6.0?
cause thats the vb version i am using right now for my thesis.
reply asap pls..
thank you so much!

[dee-u]

are all this codes available in VB 6.0?
cause thats the vb version i am using right now for my thesis.
reply asap pls..
thank you so much!

Yes this is all in Visual Basic 6.0 but as Rob says most of the stuffs here are already in the official FAQ section which contains more topics and more elaborate on their explanations.

[dicktracy007]

thanks a ton for all these codes put together in one location. Is very useful for me.

[si_the_geek]

As dee-u said most of these, along with many other things, are in our Classic VB FAQs (in the FAQ forum, which is shown near the top of our home page) - all organised in an easier to read format.

This thread was created while the FAQs were in progress, and several of the posts here are duplicated in the FAQs (often with more explanation and/or alternative methods of doing the same thing).