Membikin Menu Multi Kolom (Win32) - (API Call)

Private Type MENUITEMINFO
    cbSize As Long
    fMask As Long
    fType As Long
    fState As Long
    wID As Long
    hSubMenu As Long
    hbmpChecked As Long
    hbmpUnchecked As Long
    dwItemData As Long
    dwTypeData As String
    cch As Long
End Type

Private Const MF_MENUBARBREAK = &H20&
Private Const MF_MENUBREAK = &H40&
Private Const MF_STRING = &H0&
Private Const MF_HELP = &H4000&
Private Const MFS_DEFAULT = &H1000&
Private Const MIIM_ID = &H2
Private Const MIIM_SUBMENU = &H4
Private Const MIIM_TYPE = &H10
Private Const MIIM_DATA = &H20
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal B As Boolean, lpMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long

Private Sub Command1_Click()
    Dim mnuItemInfo As MENUITEMINFO, hMenu As Long, hSubMenu As Long
    Dim BuffStr As String * 80

    hMenu = GetMenu(Me.hwnd)
    BuffStr = Space(80)
    With mnuItemInfo
        .cbSize = Len(mnuItemInfo)
        .dwTypeData = BuffStr & Chr(0)
        .fType = MF_STRING
        .cch = Len(mnuItemInfo.dwTypeData)
        .fState = MFS_DEFAULT
        .fMask = MIIM_ID Or MIIM_DATA Or MIIM_TYPE Or MIIM_SUBMENU
    End With
    hSubMenu = GetSubMenu(hMenu, 0)
    If GetMenuItemInfo(hSubMenu, 2, True, mnuItemInfo) = 0 Then
        MsgBox "GetMenuItemInfo failed. Error: " & Err.LastDllError, , "Error"
    Else
        mnuItemInfo.fType = mnuItemInfo.fType Or MF_MENUBARBREAK
        If SetMenuItemInfo(hSubMenu, 2, True, mnuItemInfo) = 0 Then
            MsgBox "SetMenuItemInfo failed. Error: " & Err.LastDllError, , "Error"
        End If
    End If
    DrawMenuBar (Me.hwnd)
End Sub

Private Sub Form_Load()
    Dim mnuItemInfo As MENUITEMINFO, hMenu As Long, hSubMenu As Long
    Dim BuffStr As String * 80

    hMenu = GetMenu(Me.hwnd)
    BuffStr = Space(80)

    With mnuItemInfo
        .cbSize = Len(mnuItemInfo)
        .dwTypeData = BuffStr & Chr(0)
        .fType = MF_STRING
        .cch = Len(mnuItemInfo.dwTypeData)
        .fState = MFS_DEFAULT
        .fMask = MIIM_ID Or MIIM_DATA Or MIIM_TYPE Or MIIM_SUBMENU
    End With
    hSubMenu = GetSubMenu(hMenu, 1)
    If GetMenuItemInfo(hSubMenu, 2, True, mnuItemInfo) = 0 Then
        MsgBox "GetMenuItemInfo failed. Error: " & Err.LastDllError, , "Error"
    Else
        mnuItemInfo.fType = mnuItemInfo.fType Or MF_MENUBREAK
        If SetMenuItemInfo(hSubMenu, 2, True, mnuItemInfo) = 0 Then
            MsgBox "SetMenuItemInfo failed. Error: " & Err.LastDllError, , "Error"
        End If
    End If
    DrawMenuBar (Me.hwnd)
End Sub

READ MORE - Membikin Menu Multi Kolom (Win32) - (API Call)

Membikin Area Transparan Obyek Geometri - (API Call)

Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long

Private Function fMakeATranspArea(AreaType As String, pCordinate() As Long) As Boolean
    Const RGN_DIFF = 4
    Dim lOriginalForm As Long
    Dim ltheHole As Long
    Dim lNewForm As Long
    Dim lFwidth As Single
    Dim lFHeight As Single
    Dim lborder_width As Single
    Dim ltitle_height As Single
    On Error GoTo Trap
    lFwidth = ScaleX(Width, vbTwips, vbPixels)
    lFHeight = ScaleY(Height, vbTwips, vbPixels)
    lOriginalForm = CreateRectRgn(0, 0, lFwidth, lFHeight)

    lborder_width = (lFHeight - ScaleWidth) / 2
    ltitle_height = lFHeight - lborder_width - ScaleHeight
    Select Case AreaType

        Case "Elliptic"
            ltheHole = CreateEllipticRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4))
        Case "RectAngle"
            ltheHole = CreateRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4))
        Case "RoundRect"
            ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(5), pCordinate(6))
        Case "Circle"
            ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(3), pCordinate(4))
        Case Else
            MsgBox "Unknown Shape!!"
            Exit Function
    End Select
    lNewForm = CreateRectRgn(0, 0, 0, 0)
    CombineRgn lNewForm, lOriginalForm, _
    ltheHole, RGN_DIFF

    SetWindowRgn hWnd, lNewForm, True
    Me.Refresh
    fMakeATranspArea = True
    Exit Function
Trap:
    MsgBox "error Occurred. Error # " & Err.Number & ", " & Err.Description
End Function

Private Sub Command1_Click()
    Dim lParam(1 To 6) As Long
    lParam(1) = 100
    lParam(2) = 100
    lParam(3) = 250
    lParam(4) = 250
    lParam(5) = 50
    lParam(6) = 50
    Call fMakeATranspArea("Circle", lParam())
End Sub

READ MORE - Membikin Area Transparan Obyek Geometri - (API Call)

Asc: Mengenal Fungsi String VB6

Asc - Kegunaan fungsi string dalam VB6.

Kegunaan Asc dalam VB6:

Fungsi Asc berguna untuk memperoleh nilai angka yang merupakan kode ANSI dari sebuah string.

Contoh Asc dalam VB6:

    txtHasil.Text = Asc("A") 'maka akan memperoleh nilai 65
    'demikian juga
    txtHasil.Text = Asc("AAA")  'maka akan memperoleh nilai 65
    'demikian juga
    txtHasil.Text = Asc("AB") 'akan memperoleh nilai 65

Catatan mengenai Asc dalam VB6:

Dari ketiga contoh di atas yang menjadi patokan adalah karakter pertama, selanjutnya karakter pertama tersebut akan dirubah menjadi kode ANSI berupa angka, yang secara kebetulan dalam contoh di atas adalah karakter A dan kode ANSI untuk karakter A adalah 65.

Demikian fungsi string Asc dalam VB6, semoga bermanfaat bagi mereka yang sedang ingin mengetahui fungsi-fungsi string dalam VB6 khususnya fungsi string Asc.

READ MORE - Asc: Mengenal Fungsi String VB6

LCase: Mengenal Fungsi String VB6

LCase - Mengenal fungsi-fungsi string dalam VB6

 Kegunaan LCase dalam VB6:

Fungsi LCase berguna untuk mengkonversi seluruh string menjadi huruf kecil.

Contoh LCase dalam VB6:

    Msgbox LCase("Jakarta Bandung") 'maka jakarta bandung

Demikian kegunaan fungsi string LCase dalam VB6, semoga bermanfaat.

READ MORE - LCase: Mengenal Fungsi String VB6