Tutorialized Stuffs

Option Explicit

Dim ConfigFile As String

Private Sub cmdRetrieve_Click()
    'Set the Configuration File Name
    ConfigFile = App.Path & "\CONFIG.INI"
    
    lblName.Caption = GetINISetting("USER", "NAME", ConfigFile)
    lblTime.Caption = GetINISetting("USER", "TIME", ConfigFile)
    
End Sub

Private Sub cmdSave_Click()
    'Set the Configuration File Name
    ConfigFile = App.Path & "\CONFIG.INI"
    
    'Check for empty values
    If txtSetting.Text = "" Then
        MsgBox "Please type your name on the textbox provided.", vbCritical, "Settings"
        txtSetting.SetFocus
        Exit Sub
    End If
    
    'Put the name and the time into the config file
    PutINISetting "USER", "NAME", txtSetting.Text, ConfigFile
    PutINISetting "USER", "TIME", Format(Now, "yyyy-mm-dd hh:mm:ss AMPM"), ConfigFile
    
    MsgBox "Settings have been saved.", vbInformation, "Settings"
    
End Sub

Option Explicit

'API Function to read information from INI File
Public 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

'API Function to write information to the INI File
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

'Get the INI Setting from the File
Public Function GetINISetting(ByVal sHeading As String, _
    ByVal sKey As String, _
    sINIFileName) As String
    
    Const cparmLen = 50
    Dim sReturn As String * cparmLen
    Dim sDefault As String * cparmLen
    Dim lLength As Long
    lLength = GetPrivateProfileString(sHeading, _
            sKey, _
            sDefault, _
            sReturn, _
            cparmLen, _
            sINIFileName)
            
    GetINISetting = Mid(sReturn, 1, lLength)
End Function

'Save INI Setting in the File
Public Function PutINISetting(ByVal sHeading As String, _
    ByVal sKey As String, _
    ByVal sSetting As String, _
    sINIFileName) As Boolean
    
    Const cparmLen = 50
    Dim sReturn As String * cparmLen
    Dim sDefault As String * cparmLen
    Dim aLength As Long
    aLength = WritePrivateProfileString(sHeading, _
        sKey, _
        sSetting, _
        sINIFileName)
        
    PutINISetting = True
End Function

Public 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



Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Public Const SWP_NOACTIVATE = &H10
Public Const SWP_SHOWWINDOW = &H40
Public Const SWP_NOMOVE = 2
Public Const SWP_NOSIZE = 1

Private Sub Form_Load()

    Dim R as long

    R = SetWindowPos(SheetName.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)

End sub 

Private Sub Form_Activate()

    Dim R as long

    R = SetWindowPos(SheetName.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)

End sub 

Private sub SuppPriority()

    Dim R as long

    R= SetWindowPos(NomFeuille.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)

End sub

Option Explicit

'Purpose     :  Compact a JET (Access) database using ADO
'Inputs      :  sDatabasePath                   The path to the database path eg. C:\nwind.mdb
'               [bEncryptDatabase]              If True, encrypts the contents of the database
'Outputs     :  Returns zero if successful, else returns error code
'Notes       :  Requires "Microsoft Jet and Replication Objects X.X library",
'               where (X.X is greater than or equal to 2.1)
'               Compacts the database by creating a temporary database with the extension .tmp then,
'               if the compaction is successful, it overwrites the original database.
'               Will not work if anyone else is connected to the database.
'Revisions   :
'Assumptions :

Function DatabaseCompact(sDatabasePath As String, Optional bEncryptDatabase As Boolean = False) As Long
    Dim oJRO As Object 'JRO.JetEngine

    On Error GoTo ErrFailed
    
    If Len(Dir$(sDatabasePath & ".tmp")) Then
        'Delete the existing temp database
        VBA.Kill sDatabasePath & ".tmp"
    End If
    
    Set oJRO = CreateObject("JRO.JetEngine")
    
    If bEncryptDatabase Then
        'Compact and encrypt the database
        oJRO.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sDatabasePath, "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sDatabasePath & ".tmp;Jet OLEDB:Encrypt Database=True"
    Else
        'Compact the database
        oJRO.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sDatabasePath, "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sDatabasePath & ".tmp;Jet OLEDB:Engine Type=4"
    End If
    
    'Delete the existing database
    VBA.Kill sDatabasePath
    'Rename the compacted database
    Name sDatabasePath & ".tmp" As sDatabasePath
    Set oJRO = Nothing

    Exit Function

ErrFailed:
    Debug.Print "Failed to compact database: " & Err.Description
    DatabaseCompact = Err.Number
    Set oJRO = Nothing
    On Error GoTo 0
End Function

'Demonstration routine
Sub Test()
    Dim lRes As Long
    On Error Resume Next
    lRes = DatabaseCompact("C:\test.mdb", True)
    If lRes = 0 Then
        MsgBox "Succeeded in compacting database...", vbInformation
    Else
        'Show error message
        MsgBox Error(lRes)
    End If
    Exit Sub
ErrFailed:
    MsgBox Err.Description
End Sub

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

'# Open file (quotes are used so that the actual value that is passed is "C:\test.txt"
Private Sub cmdOpen_Click()

    ShellExecute 0, vbNullString, """"C:\test.txt"""", vbNullString, vbNullString, vbNormalFocus

End Sub

'# Open url
Private Sub cmdOpen_Click()

    ShellExecute 0, vbNullString, "http://tutorpinoy.blogspot.com", vbNullString, vbNullString, vbNormalFocus

End Sub

'# Open email address
Private Sub cmdOpen_Click()

    ShellExecute 0, vbNullString, "mailto:tu2rpinoy@gmail.com", vbNullString, vbNullString, vbNormalFocus

End Sub

'#Open System Apps
Private Sub cmdOpen_Click()

    ShellExecute 0, vbNullString, "Notepad", vbNullString, vbNullString, vbNormalFocus

End Sub

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 


Private Sub AutosizeColumns(ByVal TargetListView As ListView)
Const SET_COLUMN_WIDTH    As Long = 4126
Const AUTOSIZE_USEHEADER  As Long = -2
Dim lngColumn As Long 

For lngColumn = 0 To (TargetListView.ColumnHeaders.Count - 1)
Call SendMessage(TargetListView.hwnd, SET_COLUMN_WIDTH, lngColumn, ByVal AUTOSIZE_USEHEADER)
Next lngColumn 

End Sub

Option Explicit

'   #################################################################
'   #  By:         Cromwell Bayon (omelsoft@gmail.com)
'   #  Description:    Progress Bar Using Custom Image
'   #  Date:           Friday 12th of April, 2013 
'   #################################################################

' DECLARE PROGRESS BAR VARIABLES
Public iMax As Long, _
       iMin As Long, _
       u_Val As Long, _
       xMinVal As Long, _
       xMaxVal As Long, _
       xPBar As Long       

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

' INITIALIZE PROGRESS BAR STATE
Public Function initProgress(ByVal xMin As Long, ByVal xMax As Long, pBar As Image) 

    pBar.Visible = True
    lblPercent.Caption = ""

    'SAVE INITIAL VALUES
    xMinVal = xMin

    'THIS IS THE WIDTH OF OUR PROGRESS BAR FACE
    'MAY ALSO SET THIS TO FIX VALUE
    'xPbar = 7080

    xPBar = pBar.Width

    'THE INITIAL WIDTH OF THE PROGRESS BAR FACE
    pBar.Width = 1

    'WE'LL TRAP ZERO VALUES
    If xMin = 1 Then
       xMaxVal = xMax
    Else
       xMaxVal = Abs(xMax - xMin)
    If xMin < 1 Then 
       xMaxVal = xMaxVal + 1
    End If
End Function

'DRAW PROGRESS BAR STATE
Public Function drawProgress(ByVal xVal As Long)
   'GET THE ABSOLUTE VALUE OF THE xVal
   u_Val = Abs(xVal - xMinVal) + 1

   'PROGRESS BAR WIDTH
   pBar.Width = (u_Val * xPBar) / xMaxVal

   'UPDATE PERCENTAGE OF THE PROGRESS BAR
   lblPercent.Caption = CStr(Int(u_Val * 100 / xMaxVal)) & " %"
End Function

Private Sub cmdStart_Click()
   If txtMax.Text < 1 Then
     'DO SOME TRAPPING HERE LIKE NO RECORD FOUND WHILE GETTING DATA FROM A DATABASE
      MsgBox "Max value must be greater than 1."
      Exit Sub
   End If

   'INITIALIZE MIN AND MAX VALUES
   initProgress txtMin.Text, txtMax.Text, Me.pBar

   'ENABLE TIMER
   Timer1.Enabled = True
End Sub

Private Sub Timer1_Timer()
   Dim i As Integer

   For i = 1 To xMaxVal

       'DRAW PROGRESS BAR
       drawProgress i

       'PAUSE FOR 25 milli SECONDS TO IMPLEMENT A SMOOTH PROGRESS
       Sleep 25

       'LET OS DO OTHER TASKS
       DoEvents    
    Next i

    If Mid(lblPercent.Caption, 1, 3) >= 100 Then
       Timer1.Enabled = False
       MsgBox "Done! ^_^", vbInformation, Me.Caption
    End If

End Sub