Data Link Properties Dialog Box Cara Menampilkannya

'simpan kode di bawah pada modul Option Explicit 
 
Public Function getADOConnectionString(Optional ByVal cnStringToEdit As String = "", Optional sPrePromptUserMessage As String = "") As String 
 
  Dim sActivity As String 
  Dim dl As Object 
  Dim cn As Object 
 
    On Error GoTo ErrGetAdoConnectionString 
    sActivity = "Creating Datalinks object." 
 
    Set dl = CreateObject("DataLinks") 
 
    If Not "" = cnStringToEdit) Then 
 
        If Not "" = sPrePromptUserMessage) Then 
            MsgBox sPrePromptUserMessage, vbInformation, "Connecting to Database..." 
        End If 
        sActivity = "Creating ADODB.Connection object" 
        Set cn = CreateObject("ADODB.Connection") 
 
        cn.ConnectionString = "Provider=SQLOLEDB.1;Initial Catalog=PUBS" 
 
        sActivity = "Prompting user to  edit  connect string" 
        dl.PromptEdit cn 
 
      Else 
        sActivity = "Prompting user for  new  connect string" 
        Set cn = dl.PromptNew() 
 
    End If 
 
    If cn Is Nothing Then 
        getADOConnectionString = "" 
        Exit Function 
    End If 
 
    getADOConnectionString = cn.ConnectionString 
 
    Set cn = Nothing 
 
Exit Function 
 
ErrGetAdoConnectionString: 
 
  Dim sMsg As String 
 
    Set cn = Nothing 
 
    sMsg = "Error While [" + sActivity + "].  Details are below: " + vbCrLf 
    sMsg = sMsg + "Description:[" + Err.Description + "]." + vbCrLf 
    sMsg = sMsg + "Source:[" & Err.Source & "]." + vbCrLf 
    sMsg = sMsg + "Number:[" & Err.Number & "]." + vbCrLf 
    sMsg = sMsg + "Help File:[" & Err.HelpFile & "]." + vbCrLf 
    MsgBox sMsg, vbCritical, "Error Connecting to Database." 
 
End Function 

Contoh penggunaan fungsi di atas:

'simpan kode di bawah pada form Option Explicit 
 
Private Sub Command1_Click() 
 
On Error GoTo ErrHandler 
 
    Dim strCon As String 
    strCon = getADOConnectionString() 
    If strCon = "" Then Exit Sub 
    'kode selanjutnya disini      
    Exit Sub 
     
ErrHandler: 
 
    MsgBox Err.Number & vbNewLine & Err.Description, vbExclamation + vbOKOnly, "Connection Error" 
 
End Sub 

READ MORE - Data Link Properties Dialog Box Cara Menampilkannya

VB6 Code - Input Textbox Hanya Untuk Numeric

Artikel ini diberi judul input textbox hanya untuk numeric, maksudnya ialah sebuah TextBox hanya dapat diisi dengan angka saja. Kodenya kami buat menjadi sebuah fungsi agar lebih mudah dalam penggunaan serta memiliki sifat dapat digunakan kembali (reusable). Adapun kode yang dimaksud:

Option Explicit

Private Sub OnlyNumeric(KeyAscii As Integer)

  Select Case KeyAscii
      Case 48 To 57                        ' numeric
      Case 8                               ' backspace
      Case Else: KeyAscii = 0
  End Select

End Sub

Cara penggunaan Fungsi TextBox hanya untuk numerik

Private Sub Text1_KeyPress(KeyAscii As Integer)
  OnlyNumeric KeyAscii
End Sub

Posted by Mesin Posting 1.0 Created by http://khoiriyyah.blogspot.com

READ MORE - VB6 Code - Input Textbox Hanya Untuk Numeric

Tag [pre] Yang Powerfull Untuk Menuliskan Kode Di Postingan

Pernahkah Anda menulis kode dengan menggunakan tag <PRE> di blogspot. Jika belum, mungkin ini saatnya. Mengapa tag <PRE>? bukankah lebih baik menggunakan syntax highlighter?

Tag <PRE> dalam kode HTML digunakan khusus untuk menuliskan kode. Dengan menggunakan tag <PRE> maka sebuah postingan akan memelihara indent dari kode tersebut, ini sangatlah penting.

Penggunaan tag <PRE>:
<PRE> code HTML, VB, C++, CSS, dll </PRE>

Contoh kode CSS yang menggunakan tag <pre>:

<b:includable id='feedLinks'>
<b:if cond='data:blog.pageType != &quot;item&quot;'> <!-- Blog feed links -->
<b:if cond='data:feedLinks'>
<div class='blog-feeds'>
<b:include data='feedLinks' name='feedLinksBody'/>
</div>
</b:if>

<b:else/> <!--Post feed links -->
<div class='post-feeds'>
<b:loop values='data:posts' var='post'>
<b:if cond='data:post.allowComments'>
<b:if cond='data:post.feedLinks'>
<b:include data='post.feedLinks' name='feedLinksBody'/>
</b:if>
</b:if>
</b:loop>
</div>
</b:if>
</b:includable>

Bandingkan dengan kode di bawah:

<b:includable id='feedLinks'>
<b:if cond='data:blog.pageType != &quot;item&quot;'> <!-- Blog feed links -->
<b:if cond='data:feedLinks'>
<div class='blog-feeds'>
<b:include data='feedLinks' name='feedLinksBody'/>
</div>
</b:if>

<b:else/> <!--Post feed links -->
<div class='post-feeds'>
<b:loop values='data:posts' var='post'>
<b:if cond='data:post.allowComments'>
<b:if cond='data:post.feedLinks'>
<b:include data='post.feedLinks' name='feedLinksBody'/>
</b:if>
</b:if>
</b:loop>
</div>
</b:if>
</b:includable>

Kode VB6.0 di bawah ini menggunakan tag <PRE>:

'Automatic select listbox when mouse over
Option Explicit

Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function LBItemFromPt Lib "COMCTL32.DLL" (ByVal hLB As Long, ByVal ptX As Long, ByVal ptY As Long, ByVal bAutoScroll As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long

Private Const LB_SETCURSEL = &H186
Private Const LB_GETCURSEL = &H188

Private Type POINTAPI
X As Long
Y As Long
End Type

Private Sub HightLightListBox(ByVal hwndLB As Long, ByVal X As Single, ByVal Y As Single)

Dim IndexItem As Long
Dim Point As POINTAPI

Point.X = X \ Screen.TwipsPerPixelX
Point.Y = Y \ Screen.TwipsPerPixelY

Call ClientToScreen(hwndLB, Point)

IndexItem = LBItemFromPt(hwndLB, Point.X, Point.Y, False)

If IndexItem <> SendMessage(hwndLB, LB_GETCURSEL, 0, 0) Then
Call SendMessage(hwndLB, LB_SETCURSEL, IndexItem, 0)
End If

End Sub

Private Sub Form_Load()
Dim i As Long
For i = 0 To 100
List1.AddItem 1234567 + i
Next
End Sub

Private Sub List1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
HightLightListBox List1.hwnd, X, Y
End Sub

Bandingkan dengan yang di bawah:

'Automatic select listbox when mouse over
Option Explicit

Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function LBItemFromPt Lib "COMCTL32.DLL" (ByVal hLB As Long, ByVal ptX As Long, ByVal ptY As Long, ByVal bAutoScroll As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long

Private Const LB_SETCURSEL = &H186
Private Const LB_GETCURSEL = &H188

Private Type POINTAPI
X As Long
Y As Long
End Type

Private Sub HightLightListBox(ByVal hwndLB As Long, ByVal X As Single, ByVal Y As Single)

Dim IndexItem As Long
Dim Point As POINTAPI

Point.X = X \ Screen.TwipsPerPixelX
Point.Y = Y \ Screen.TwipsPerPixelY

Call ClientToScreen(hwndLB, Point)

IndexItem = LBItemFromPt(hwndLB, Point.X, Point.Y, False)

If IndexItem <> SendMessage(hwndLB, LB_GETCURSEL, 0, 0) Then
Call SendMessage(hwndLB, LB_SETCURSEL, IndexItem, 0)
End If

End Sub

Private Sub Form_Load()
Dim i As Long
For i = 0 To 100
List1.AddItem 1234567 + i
Next
End Sub

Private Sub List1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
HightLightListBox List1.hwnd, X, Y
End Sub

Manakah yang menurut Anda lebih baik?

READ MORE - Tag [pre] Yang Powerfull Untuk Menuliskan Kode Di Postingan

VB6 Code - Fungsi Untuk Mengganti Extension Sebuah File

Mengenai fungsi VB6 untuk mengganti extension sebuah file. adapun fungsi VB6 untuk mengganti extention sebuah file adalah sebagai berikut:

Public Function ChangeFileExt(ByVal FileName As String, ByVal Extention As String)
 Dim str() As String, NewFile As String
 If InStr(1, FileName, ".") Then
     str = Split(FileName, ".")
     NewFile = Replace(FileName, str(UBound(str)), Extention)
     Name FileName As NewFile
 Else
     Name FileName As FileName & "." & Extention
 End If
End Function

Cara penggunaan fungsi untuk mengganti extension sebuah file:

Private Sub Form_Load()
 Call ChangeFileExt("C:\bo.ot.tmp", "exe")
End Sub

READ MORE - VB6 Code - Fungsi Untuk Mengganti Extension Sebuah File