	Sign In Sign-Up

How to...

How to...,

All the subjects will be grouped (about 10-15 per page) for an easy download and update.

How to ...

Check DCOM support

Public Declare Function GetProcAddress Lib "kernel32" _
    (ByVal hModule As Long, ByVal lpProcName As String) As Long

Public Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" _
    (ByVal lpModuleName As String) As Long
        
Public 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
    
Public 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
    
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

Public Const ERROR_SUCCESS = 0
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const STANDARD_RIGHTS_ALL = &H1F0000
Public Const KEY_QUERY_VALUE = &H1
Public Const KEY_SET_VALUE = &H2
Public Const KEY_CREATE_SUB_KEY = &H4
Public Const KEY_ENUMERATE_SUB_KEYS = &H8
Public Const KEY_NOTIFY = &H10
Public Const KEY_CREATE_LINK = &H20
Public Const SYNCHRONIZE = &H100000
Public Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or _
    KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or _
    KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))

Sub Main()
 If DCOMOK Then
  MsgBox "DCOM instaled!"
 Else
  MsgBox "DCOM not instaled!"
 End If
End Sub

Private Function DCOMOK() As Boolean
    'Determine if DCOM (Distributed COM) can be used. It can if it
    'is installed and is enabled on the current machine.
    'Dim bOK As Boolean
    Dim bPresent As Boolean
    Dim bEnabled As Boolean
    Dim hKey As Long
    Dim lpType As Long
    Dim lpData
    Dim lResult As Long
    Dim lpcbData As Long
    
    lResult = GetProcAddress(GetModuleHandle("OLE32"), "CoInitializeEx")
    If lResult <> 0 Then
        bPresent = True
    Else
        bPresent = False
    End If
    
    lResult = RegOpenKeyEx(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Ole", 0, _
        KEY_ALL_ACCESS, hKey)
    lpcbData = Len("EnableDCOM")    '10
    
    If lResult = ERROR_SUCCESS Then
        lResult = RegQueryValueEx(ByVal hKey, "EnableDCOM", 0, ByVal lpType, lpData, lpcbData)
    End If
    
    If lResult = ERROR_SUCCESS Then
        bEnabled = True
        RegCloseKey (hKey)
    Else
        bEnabled = False
    End If
    
    If bEnabled And bPresent Then
        DCOMOK = True
    Else
        DCOMOK = False
    End If
End Function

Rows number in a text-box

Public 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

Public Const EM_GETLINECOUNT = &HBA

Sub Text1_Change()
    Dim lineCount as Long
    On Local Error Resume Next
  
   'get/show the number of lines in the edit control
    lineCount = SendMessageLong(Text1.hwnd, EM_GETLINECOUNT, 0&, 0&)
    Label1 = Format$(lineCount, "##,###")
End Sub

Active connection to the Internet (Win 9x)

Public Const ERROR_SUCCESS = 0&
Public Const APINULL = 0&
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public ReturnCode As Long

Declare Function RegCloseKey Lib "advapi32.dll" (ByVal _
hKey As Long) As Long

Declare Function RegOpenKey Lib "advapi32.dll" Alias _
"RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As _
String, phkResult As Long) As Long

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

Public Function ActiveConnection() As Boolean
Dim hKey As Long
Dim lpSubKey As String
Dim phkResult As Long
Dim lpValueName As String
Dim lpReserved As Long
Dim lpType As Long
Dim lpData As Long
Dim lpcbData As Long
ActiveConnection = False
lpSubKey = "System\CurrentControlSet\Services\RemoteAccess"
ReturnCode = RegOpenKey(HKEY_LOCAL_MACHINE, lpSubKey, _
phkResult)

If ReturnCode = ERROR_SUCCESS Then
    hKey = phkResult
    lpValueName = "Remote Connection"
    lpReserved = APINULL
    lpType = APINULL
    lpData = APINULL
    lpcbData = APINULL
    ReturnCode = RegQueryValueEx(hKey, lpValueName, _
    lpReserved, lpType, ByVal lpData, lpcbData)
    lpcbData = Len(lpData)
    ReturnCode = RegQueryValueEx(hKey, lpValueName, _
    lpReserved, lpType, lpData, lpcbData)
    
    If ReturnCode = ERROR_SUCCESS Then
        If lpData = 0 Then
            ActiveConnection = False
        Else
            ActiveConnection = True
        End If
    End If
RegCloseKey (hKey)
End If
End Function

Get Internet connection status

Public Declare Function InternetGetConnectedState _
Lib "wininet.dll" (ByRef lpSFlags As Long, _
ByVal dwReserved As Long) As Long

Public Const INTERNET_CONNECTION_LAN As Long = &H2
Public Const INTERNET_CONNECTION_MODEM As Long = &H1

Public Declare Function InternetGetConnectedState _
Lib "wininet.dll" (ByRef lpSFlags As Long, _
ByVal dwReserved As Long) As Long

Public Function Online() As Boolean
    'If you are online it will return True, otherwise False
    Online = InternetGetConnectedState(0& ,0&)
End Function

Public Function ViaLAN() As Boolean
Dim SFlags As Long
'return the flags associated with the connection
Call InternetGetConnectedState(SFlags, 0&)
'True if the Sflags has a LAN connection
ViaLAN = SFlags And INTERNET_CONNECTION_LAN
End Function

Public Function ViaModem() As Boolean
Dim SFlags As Long
'return the flags associated with the connection
Call InternetGetConnectedState(SFlags, 0&)
'True if the Sflags has a modem connection
ViaModem = SFlags And INTERNET_CONNECTION_MODEM
End Function

Private Sub Command1_Click() 
Text1 = ViaLAN() 
Text2 = ViaModem() 
Text3 = Online()
End Sub

Get taskbar type and place

Private Declare Function SHAppBarMessage Lib "shell32.dll" (ByVal dwMessage
As Long, pData As APPBARDATA) As Long

Private Const ABM_GETSTATE = &H4

Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Private Type APPBARDATA
        cbSize As Long
        hwnd As Long
        uCallbackMessage As Long
        uEdge As Long
        rc As RECT
        lParam As Long '  message specific
End Type

Dim p As APPBARDATA
Dim rez As Long

Private Sub Command1_Click()
rez = SHAppBarMessage(ABM_GETSTATE, p)
Select Case rez
Case 0
    Label1 = "No always-on-top, no auto hide"
Case 1
    Label1 = "No always-on-top, auto hide"
Case 2
    Label1 = "Always-on-top, no auto hide"
Case 3
    Label1 = "Always-on-top, auto hide"
End Select
End Sub

Hide the taskbar

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal
lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal
nCmdShow As Long) As Long

Private Const SW_HIDE = 0
Private Const SW_SHOW = 5

Dim taskbar As Long

Private Sub Command1_Click()
ShowWindow taskbar, SW_HIDE
End Sub

Private Sub Command2_Click()
ShowWindow taskbar, SW_SHOW
End Sub

Private Sub Form_Load()
taskbar = FindWindow("Shell_TrayWnd", vbNullString)
End Sub

Open password protected database (DAO)

Dim d As DAO.Database
Dim r As DAO.Recordset

Private Sub Form_Load()
Set d = DBEngine.Workspaces(0).OpenDatabase("c:\db1.mdb", False, True, ";UID=Admin;PWD=parola;")
Set r = d.OpenRecordset("Table1")
End Sub

Open password protected database (ODBC)

Dim w As DAO.Workspace
Dim d As DAO.Database
Dim r As DAO.Recordset


Private Sub Form_Load()
Set w = DBEngine.CreateWorkspace("WorkSpaceTest", "Admin", "", dbUseODBC)
DBEngine.Workspaces.Append w
Set d = w.OpenDatabase("", dbDriverNoPrompt, , "ODBC;DRIVER=Microsoft Access driver (*.mdb);DBQ=c:\db1.mdb;UID=Admin;PWD=parola;")
Set r = d.OpenRecordset("Table1")
End Sub

Play a WAV file

   '--[Form1.frm]------------------------
   Option Explicit
   Const pathWavFiles = "C:\WinNT\Media\"

   Private Sub Command1_Click()
      PlayWav "tada.wav"
   End Sub

   Sub PlayWav(SoundName As String)
      Dim tmpSoundName As String
      Dim wFlags%, X%
      tmpSoundName = pathWavFiles & SoundName
      wFlags% = SND_ASYNC Or SND_NODEFAULT
      X% = sndPlaySound(tmpSoundName, wFlags%)
   End Sub
   '-------------------------------------
   '--[Module1.bas]----------------------
   ' WAV Sound values
   Global Const SND_SYNC = &H0
   Global Const SND_ASYNC = &H1
   Global Const SND_NODEFAULT = &H2
   Global Const SND_LOOP = &H8
   Global Const SND_NOSTOP = &H10

   Public Declare Function sndPlaySound& _
      Lib "winmm.dll" Alias "sndPlaySoundA" _
      (ByVal lpszSoundName As String, ByVal uFlags As Long)
   '-------------------------------------

Wait some seconds

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

    Sub Pause(ByVal fSeconds As Single)
    '
    ' Pause execution for specified # of seconds [fSeconds]
    '
       Dim fTimer As Single  ' initial timer value
       fTimer = Timer
       Do While Timer - fTimer < fSeconds
         Sleep 200
         DoEvents
          '
          ' if we cross midnight, back up one day
          ' one day in seconds = 24*60*60 = 86400
          '
          If Timer < fTimer Then
              fTimer = fTimer - 86400
          End If
       Loop
    End Sub

Encrypt/decrypt functions

Se definesc constantele ENCRYPT_OFFSET si ENCRYPT_BASE, apoi:

    Function EncryptString(ByVal sSource As String) As String
    '
    ' Does XOR encryption on string
    '
     Dim sEncrypted As String
     Dim nLength As Long
     Dim nLoop As Long
     Dim nTemp As Integer

     nLength = Len(sSource)
     sEncrypted = Space$(nLength)
     For nLoop = 1 To nLength
      nTemp = Asc(Mid$(sSource, nLoop, 1))
      If nLoop Mod 2 Then
       nTemp = nTemp - ENCRYPT_OFFSET
      Else
       nTemp = nTemp + ENCRYPT_OFFSET
      End If
      nTemp = nTemp Xor (ENCRYPT_BASE - ENCRYPT_OFFSET)
      Mid$(sEncrypted, nLoop, 1) = Chr$(nTemp)
     Next
     EncryptString = sEncrypted
    End Function

    Function DecryptString(ByVal sSource As String) As String
    '
    ' Does XOR decryption on string
    '
     Dim sDecrypted As String
     Dim nLength As Long
     Dim nLoop As Long
     Dim nTemp As Integer

     nLength = Len(sSource)
     sDecrypted = Space$(nLength)
     For nLoop = 1 To nLength
      nTemp = Asc(Mid$(sSource, nLoop, 1)) Xor _
                    (ENCRYPT_BASE - ENCRYPT_OFFSET)
      If nLoop Mod 2 Then
       nTemp = nTemp + ENCRYPT_OFFSET
      Else
       nTemp = nTemp - ENCRYPT_OFFSET
      End If
      Mid$(sDecrypted, nLoop, 1) = Chr$(nTemp)
     Next
     DecryptString = sDecrypted
    End Function

� VB Work 2000, Last update