Vesual basic codes

Vesual basic

Specify the name of the user from the registry file


Is called from the command Call get Novell Name is stored in the variable name NovellName

'Put these declarations in a new Module

Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
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
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 Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_DYN_DATA = &H80000006
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_PERFORMANCE_DATA = &H80000004
Public Const HKEY_USERS = &H80000003
Public Const ERROR_SUCCESS = 0&

Const REG_OPTION_NON_VOLATILE = &O0
Const KEY_ALL_CLASSES As Long = &HF0063
Const KEY_ALL_ACCESS = &H3F
Const REG_SZ As Long = 1

Global NovellName$

Public Function RegGetString$(hInKey As Long, ByVal subkey$, ByVal valname$)
Dim RetVal$, hSubKey As Long, dwType As Long, SZ As Long, v$, r As Long

RetVal$ = ""

r = RegOpenKeyEx(hInKey, subkey$, 0, KEY_ALL_CLASSES, hSubKey)
If r <> ERROR_SUCCESS Then GoTo Quit_Now
SZ = 256: v$ = String$(SZ, 0)
r = RegQueryValueEx(hSubKey, valname$, 0, dwType, ByVal v$, SZ)
If r = ERROR_SUCCESS And dwType = REG_SZ Then
RetVal$ = Left(v$, SZ - 1)
Else
RetVal$ = ""
End If
If hInKey = 0 Then r = RegCloseKey(hSubKey)
Quit_Now:
RegGetString$ = RetVal$

End Function

Public Function LooseSpace(invoer$) As String
Dim p%

p% = InStr(invoer$, Chr(0))
If p% <> 0 Then
LooseSpace$ = Left$(invoer$, p% - 1)
Exit Function
End If
LooseSpace$ = invoer$

End Function

Public Sub getNovellName()
Dim res&, lpBuffer$, nSize&

nSize = 8
lpBuffer = String(8, 0)
res& = GetUserName(lpBuffer, nSize)
NovellName$ = LooseSpace(Left$(lpBuffer, nSize))
'user is not logged on to a windows-network
If NovellName$ = "" Then
'the username is kept in the HKEY_LOCAL_MACHINE\NETWORK\LOGON\username
NovellName = RegGetString$(&H80000002, "NETWORK\LOGON", "username")
End If

End Sub




Determine the status of your Internet connection

'This code is placed in Moudle

Public Declare Function RasEnumConnections Lib "RasApi32.dll" Alias _
    "RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, _
    lpcConnections As Long) As Long
Public Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias _
    "RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long
Public Const RAS95_MaxEntryName = 256
Public Const RAS95_MaxDeviceType = 16
Public Const RAS95_MaxDeviceName = 32
Public Type RASCONN95
dwSize As Long
hRasCon As Long
szEntryName(RAS95_MaxEntryName) As Byte
szDeviceType(RAS95_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
Public Type RASCONNSTATUS95
dwSize As Long
RasConnState As Long
dwError As Long
szDeviceType(RAS95_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type


    'This code is placed in the "Form"


 To know how long to run Windows


Public Function IsConnected() As Boolean
   
    Dim TRasCon(255) As RASCONN95
    Dim lg As Long
    Dim lpcon As Long
    Dim RetVal As Long
    Dim Tstatus As RASCONNSTATUS95
   
    TRasCon(0).dwSize = 412
    lg = 256 * TRasCon(0).dwSize
   
    RetVal = RasEnumConnections(TRasCon(0), lg, lpcon)
   
    If RetVal <> 0 Then
        MsgBox "ERROR"
        Exit Function
    End If
   
    Tstatus.dwSize = 160
    RetVal = RasGetConnectStatus(TRasCon(0).hRasCon, Tstatus)
   
    If Tstatus.RasConnState = &H2000 Then
        IsConnected = True
    Else
        IsConnected = False
    End If
   
End Function
   
Private Sub Command1_Click()
    If IsConnected() = True Then
        MsgBox ("The device is connected to the Internet")
    Else
        MsgBox ("The device is not connected to the Internet")
    End If
End Sub












Private Declare Function GetTickCount Lib "Kernel32" () As Long
   
Private Sub Command1_Click()
    Print Format(GetTickCount / 10000 / 6, "0")
End Sub

To play a file type of mdi

We will need the tool "Mmsontrul"

Private Sub Form_Load()
    MMControl1.Visible = False
    MMControl1.DeviceType = "sequencer"
    MMControl1.FileName = ("c:\FileName.mid")
    MMControl1.Command = "open"
    MMControl1.Command = "play"
End Sub

To run a video file in Picture

We will need the tool mmcontrol

Private Sub Form_Load()
    MMControl1.FileName = ("c:\FileName.dat")
    MMControl1.Command = "open"
    MMControl1.hWndDisplay = Picture1.hWnd
End Sub

to delete any file

Private Sub Command1_Click()
    Kill ("C:\FileName.fnm")
End Sub

to play sound file /ram type/0

need to "rmoc3260.dll"


Private Sub Command1_Click()
    RealAudio1.Source = "c:\Demo.ram"
    RealAudio1.DoPlay
End Sub

open/close CD-Rom

Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" ( _
    ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _
    ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
   
Public Sub OpenCDDriveDoor(ByVal State As Boolean)
    If State = True Then
        Call mciSendString("Set CDAudio Door Open", 0&, 0&, 0&)
    Else
        Call mciSendString("Set CDAudio Door Closed", 0&, 0&, 0&)
    End If
End Sub
   
Private Sub Command1_Click()
    OpenCDDriveDoor (True)
End Sub
   
Private Sub Command2_Click()
    OpenCDDriveDoor (False)
End Sub






To change the display resolution of the screen 

set this code in " Moudel"

Public Const EWX_LOGOFF = 0
Public Const EWX_SHUTDOWN = 1
Public Const EWX_REBOOT = 2
Public Const EWX_FORCE = 4
Public Const CCDEVICENAME = 32
Public Const CCFORMNAME = 32
Public Const DM_BITSPERPEL = &H40000
Public Const DM_PELSWIDTH = &H80000
Public Const DM_PELSHEIGHT = &H100000
Public Const CDS_UPDATEREGISTRY = &H1
Public Const CDS_TEST = &H4
Public Const DISP_CHANGE_SUCCESSFUL = 0
Public Const DISP_CHANGE_RESTART = 1


Type typDevMODE
dmDeviceName As String * CCDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type


Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" ( _
    ByVal lpszDeviceName As Long, ByVal iModeNum As Long, _
    lptypDevMode As Any) As Boolean
Declare Function ChangeDisplaySettings Lib "user32" Alias _
    "ChangeDisplaySettingsA" (lptypDevMode As Any, ByVal dwFlags As Long) As Long
Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, _
    ByVal dwReserved As Long) As Long
    
    
set this code in "form"





Private Sub Command1_Click()
    Dim typDevM As typDevMODE
    Dim lngResult As Long
    Dim intAns As Integer
    
    lngResult = EnumDisplaySettings(0, 0, typDevM)
    
    With typDevM
        .dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
        .dmPelsWidth = 640 'set width(640,800,1024, etc)
        .dmPelsHeight = 480 'set length(480,600,768, etc)
    End With
    
    lngResult = ChangeDisplaySettings(typDevM, CDS_TEST)
    Select Case lngResult
        Case DISP_CHANGE_RESTART
            intAns = MsgBox( _
                "You must restart your computer to apply these changes." & vbCrLf & _
                vbCrLf & "Do you want to restart now?", vbYesNo + vbSystemModal, _
                "Screen Resolution")
            If intAns = vbYes Then Call ExitWindowsEx(EWX_REBOOT, 0)
        Case DISP_CHANGE_SUCCESSFUL
            Call ChangeDisplaySettings(typDevM, CDS_UPDATEREGISTRY)
            MsgBox "Screen resolution changed", vbInformation, _
                "Resolution Changed"
        Case Else
            MsgBox "Mode not supported", vbSystemModal, "Error"
    End Select
    
End Sub


List all files and folders within a particular folder



Sub FindDir(ByVal Path As String)
    Dim FSO As New FileSystemObject
    Dim FoldersName As Folders
    Set FoldersName = FSO.GetFolder(Path).SubFolders
    Dim FolderName As Folder
    For Each FolderName In FoldersName
        RichTextBox.Text = RichTextBox.Text & vbNewLine & FolderName
        FindDir (FolderName)
    Next
    Dim FileInFolder As Files
    Set FileInFolder = FSO.GetFolder(Path).Files
    Dim FileName As File
    For Each FileName In FileInFolder
        RichTextBox.Text = RichTextBox.Text & vbNewLine & FileName
        RichTextBox.SelStart = Len(RichTextBox.Text)
        DoEvents
    Next
End Sub