Menggunakan Fonts Tanpa Menginstalnya

Di bawah ini merupakan kode untuk menggunakan fonts tanpa harus menginstalnya.

Private Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" ByVal lpFileName As String) As Long 
Private Declare Function RemoveFontResource Lib "gdi32" Alias "RemoveFontResourceA" ByVal lpFileName As String) As Long 
 
Public Function AddFontToResource(Filename As String) 
    Dim lFont As Long 
    lFont = RemoveFontResource(Filename) 
End Function 
 
Public Function RemoveFontFromResource(Filename As String) 
    Dim lFont As Long 
    lFont = AddFontResource(Filename) 
End Function  

Contoh penggunaan fungsi di atas:

Private Sub Form_Load() 
    AddFontResource App.Path & "\Fonts\Trado.ttf" 
    Text1.FontName = "Traditional Arabic" 
End Sub 

READ MORE - Menggunakan Fonts Tanpa Menginstalnya

Mendapatkan Special Folder Menggunakan Visual Basic 6.0

Public Enum SpecialFolderIDs 
    sfidDESKTOP = &H0 
    sfidPROGRAMS = &H2 
    sfidPERSONAL = &H5 
    sfidFAVORITES = &H6 
    sfidSTARTUP = &H7 
    sfidRECENT = &H8 
    sfidSENDTO = &H9 
    sfidSTARTMENU = &HB 
    sfidDESKTOPDIRECTORY = &H10 
      sfidNETHOOD = &H13 
    sfidFONTS = &H14 
    sfidTEMPLATES = &H15 
    sfidCOMMON_STARTMENU = &H16 
    sfidCOMMON_PROGRAMS = &H17 
    sfidCOMMON_STARTUP = &H18 
    sfidCOMMON_DESKTOPDIRECTORY = &H19 
    sfidAPPDATA = &H1A 
    sfidPRINTHOOD = &H1B 
    sfidProgramFiles = &H10000 
    sfidCommonFiles = &H10001 
End Enum 
 
Public Declare Function SHGetSpecialFolderLocation Lib "shell32" (ByVal hwndOwner As Long, ByVal nFolder As SpecialFolderIDs, ByRef pIdl As Long) As Long 
Public Declare Function SHGetPathFromIDListA Lib "shell32" (ByVal pIdl As Long, ByVal pszPath As String) As Long 
 
Public Const NOERROR = 0 
    Dim sPath   As String 
    Dim IDL     As Long 
    Dim strPath As String 
    Dim lngPos As Long 
 
    ' Fill the item id list with the pointer of each folder item, rtns 0 on success 
    If SHGetSpecialFolderLocation(0, sfidPROGRAMS, IDL) = NOERROR Then 
        sPath = String$(255, 0) 
        SHGetPathFromIDListA IDL, sPath 
 
        lngPos = InStr(sPath, Chr&(0)) 
        If lngPos > 0 Then 
            strPath = Left$(sPath, lngPos - 1) 
        End If 
 
    End If 

READ MORE - Mendapatkan Special Folder Menggunakan Visual Basic 6.0

Menguji Kecepatan Sebuah Form Ketika Diload

Di bawah ini merupakan fungsi untuk menguji kecepatan load sebuah form. Berbicara mengenai uji menguji kecepatan, maka fungsi API yang digunakan umumnya GetTickCount yang terdapat dalam core dll windows yakni Kernel32.dll. Selain untuk menguji kecepatan form, kode di bawah ini bisa Anda modifikasi untuk keperluan lain, misalnya menguji kecepatan sebuah fungsi/kode dan lain-lain. Ide pembuatan fungsi ini kami dapatkan dari o-om.com, terima kasih.

Option Explicit 
 
Private Declare Function GetTickCount Lib "kernel32" () As Long 
 
Public Function FormTestSpeed(frm As Form) As Long 
    Dim lSpeedTime As Long 
    Dim SInfoSpeed As String 
    lSpeedTime = GetTickCount   
    Unload frm 
    Load frm 
    frm.Show 
    lSpeedTime = GetTickCount - lSpeedTime 
    ' this is only simulation 
    If lSpeedTime <= 50 Then 
        SInfoSpeed = "[Very Fast]" 
    ElseIf lSpeedTime >= 50 And lSpeedTime <= 100 Then 
        SInfoSpeed = "[Normal]" 
    ElseIf lSpeedTime >= 100 And lSpeedTime <= 200 Then   
        SInfoSpeed = "[Slow]" 
    ElseIf lSpeedTime >= 200 Then 
        SInfoSpeed = "[Very Slow]" 
    End If 
    frm.Caption = "Time Speed Form: " & lSpeedTime & " Milliseconds - " & SInfoSpeed 
End Function 

Contoh penggunaan fungsi di atas:

Private Sub Command1_Click() 
    FormTestSpeed Form2 
End Sub 

READ MORE - Menguji Kecepatan Sebuah Form Ketika Diload

Fungsi Untuk Memeriksa Apakah Terhubung Ke Internet

Di bawah ini fungsi untuk memeriksa, apakah komputer terhubung ke internet atau tidak?

Option Explicit 
 
Private Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, lpcConnections As Long) As Long 
Private Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long 
' 
Const RAS95_MaxEntryName = 256 
Const RAS95_MaxDeviceType = 16 
Const RAS95_MaxDeviceName = 32 
' 
Private 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 
' 
Private Type RASCONNSTATUS95 
    dwSize As Long 
    RasConnState As Long 
    dwError As Long 
      szDeviceType(RAS95_MaxDeviceType) As Byte 
    szDeviceName(RAS95_MaxDeviceName) As Byte 
End Type 
 
Private 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() 
    MsgBox IsConnected 
End Sub 

READ MORE - Fungsi Untuk Memeriksa Apakah Terhubung Ke Internet