Hanya Huruf yang bisa di Input dalam TextBoxt

PERSIAPAN			PROPERTIES
NO	CONTROL	ITEM	NAME	VALUE	KETERANGAN
1.	TextBox	1	Text	""	kosongkan

Masukkan souce ini ke dalam Form :Private Sub Text1_KeyPress(KeyAscii As Integer) If Not (KeyAscii >= Asc("a") & Chr(13) And KeyAscii <= Asc("z") & Chr(13) Or (KeyAscii >= Asc("A") & Chr(13) And KeyAscii <= Asc("Z") & Chr(13) Or KeyAscii = vbKeyBack Or KeyAscii = vbKeyDelete Or KeyAscii = vbKeySpace)) Then Beep KeyAscii = 0 End If End Sub

Hanya Angka / Numerik yang bisa di Input dalam TextBoxt

PERSIAPAN			PROPERTIES
NO	CONTROL	ITEM	NAME	VALUE	KETERANGAN
1.	TextBox	1	Text	""	kosongkan

Cara Pertama :

Masukkan souce ini ke dalam Form :Private Sub Form_Load() Text1.Text = "" End Sub Private Sub Text1_KeyPress(KeyAscii As Integer) If Not (KeyAscii >= Asc("0") & Chr(13) And KeyAscii <= Asc("9") & Chr(13)) Then Beep KeyAscii = 0 End If End Sub

Cara Kedua :

Masukkan souce ini ke dalam Form :Private Sub Form_Load() Text1.Text = "" End Sub Private Sub Text1_KeyPress(KeyAscii As Integer) If KeyAscii < 47 Or KeyAscii > 57 Then Beep KeyAscii = 0 End If End Sub

Cara Ketiga :

Masukkan souce ini ke dalam Form :Private Sub Form_Load() Text1.Text = Empty End Sub ' USAGE 'Create a form a text box Private Sub Text1_KeyPress(KeyAscii As Integer) ' Precision is 2 in this case ' Send the Precision Value same in both the Functions Call ValidateNum(Text1, 2, KeyAscii) End Sub Private Sub Text1_KeyUp(KeyCode As Integer, Shift As Integer) Call ValidateDel(Text1, 2, KeyCode) End Sub

Masukkan souce ini ke dalam Module :Option Explicit ' For validating the Floating Point Numbers ' MODULE Public Sub ValidateDel(txtnum As TextBox, ByVal m_Precision As Integer, KeyCode As Integer) Dim m_NumBeforeDot As Integer, m_NumAfterDot As Integer Dim TempInt As Integer If KeyCode = vbKeyDelete Then If m_Precision > 0 Then TempInt = InStr(txtnum, ".") If TempInt > 0 Then m_NumBeforeDot = TempInt - 1 m_NumAfterDot = Len(txtnum) - TempInt Else m_NumBeforeDot = Len(Trim(txtnum)) m_NumAfterDot = 0 TempInt = txtnum.MaxLength - m_Precision End If If (txtnum.SelStart = TempInt - 1) Then If m_NumBeforeDot + m_NumAfterDot >= txtnum.MaxLength - m_Precision Then KeyCode = 0 End If End If End If End If End Sub Public Sub ValidateNum(txtnum As TextBox, ByVal m_Precision As Integer, KeyAscii As Integer) Dim m_NumBeforeDot As Integer, m_NumAfterDot As Integer Dim TempInt As Integer If (KeyAscii <> vbKeyReturn) And _ ((KeyAscii < vbKey0) Or (KeyAscii > vbKey9)) And _ (KeyAscii <> vbKeyBack) Then If KeyAscii = 46 Then ' Dot. If m_Precision = 0 Then KeyAscii = 0 Exit Sub Else If InStr(txtnum, ".") > 0 Then KeyAscii = 0 Exit Sub End If End If Else KeyAscii = 0 Exit Sub End If End If If KeyAscii = 0 Then Exit Sub If m_Precision > 0 Then TempInt = InStr(txtnum, ".") If TempInt > 0 Then m_NumBeforeDot = TempInt - 1 m_NumAfterDot = Len(txtnum) - TempInt Else m_NumBeforeDot = Len(txtnum) If txtnum.SelStart < m_NumBeforeDot - m_Precision Then KeyAscii = 0 Exit Sub End If m_NumAfterDot = 0 TempInt = txtnum.MaxLength - m_Precision End If If KeyAscii >= vbKey0 And KeyAscii <= vbKey9 Then If Not (((m_NumBeforeDot < txtnum.MaxLength - m_Precision - 1) _ And (txtnum.SelStart < TempInt)) Or _ ((m_NumAfterDot < m_Precision) And (txtnum.SelStart >= TempInt))) Then KeyAscii = 0 End If ElseIf (KeyAscii = vbKeyBack) And (txtnum.SelStart = TempInt) Then If m_NumBeforeDot + m_NumAfterDot >= txtnum.MaxLength - m_Precision Then KeyAscii = 0 End If End If End If End Sub

Setting Aligment Label

DESKRIPSI
Mengatur Aligment Label Saat Di Load Pertama Kali.
PERSIAPAN			PROPERTIES
NO	CONTROL	ITEM	NAME	VALUE	KETERANGAN
1.	Label	1	Text	"Label1"

Masukkan souce ini ke dalam Form Private Sub Form_Load() ' Label1.Alignment = 0 'Left Justify ' Label1.Alignment = 1 'Right Justify Label1.Alignment = 2 'Center End Sub

Mengganti Caption Label

DESKRIPSI
Mengganti Caption Label Saat Di Load Pertama Kali.
PERSIAPAN			PROPERTIES
NO	CONTROL	ITEM	NAME	VALUE	KETERANGAN
1.	Label	1	Text	"Label1"

Masukkan souce ini ke dalam Form Private Sub Form_Load() Label1.Caption = "ARBI Blog's" End Sub

Membuat Form Ellip's

Source Kode

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 SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long

Private Sub Form_Load()
Dim lngRegion As Long
Dim lngReturn As Long
Dim lngFormWidth As Long
Dim lngFormHeight As Long

lngFormWidth = Me.Width / Screen.TwipsPerPixelX
lngFormHeight = Me.Height / Screen.TwipsPerPixelY
lngRegion = CreateEllipticRgn(0, 0, lngFormWidth, lngFormHeight)
lngReturn = SetWindowRgn(Me.hWnd, lngRegion, True)

End Sub

Animasi Form Keluar ( Bergerak Keatas `)

Persiapan :
- 1 command button ( Name: Command1 )

Source Kode :

Private Sub Command1_Click()
Select Case Index
Case 0
Do Until Me.Top <= -5000 Me.Move Me.Left, Me.Top - 10: DoEvents Loop Case 1 Do Until Me.Top > 20000
Me.Move Me.Left, Me.Top + 10: DoEvents
Loop
End Select
End
End Sub

Form Hanya Jalan 1x

Source ini digunakan untuk aplikasi vb yg sudah di Compie. jadi aplikasi tersebut hanya dapat berjalan 1x saja dalam 1 kompi. ok kita langsung liat source nya :

Private Sub Form_Load()
If App.PrevInstance = True Then End
End Sub

Jika nilai App.PrevInstance = False maka aplikasi tersebut dapat dijalankan lebih dari 1x.
selamat mencoba....

Mengatur Lebar (Width) Colom atau Tinggi (Height) Row MS.Excel

PERSIAPAN
NO	REFERENCES			KETERANGAN
1.	Microsoft Excel 11.0 Object Library			Cara menambahkannya adalah pilih menu : Project-references. Office yg Digunakan MS 2003
PERSIAPAN			PROPERTIES
NO	CONTROL	PCS	NAME	VALUE	KETERANGAN
2.	TextBox	2	Text	""	Text1.text=kosongkan
				8,43	Text2
			(Name)	TSize	Text2
3.	CommandButton	3	Caption	...	Command1
				Width A1	Command2
				Width All	Command3

Masukkan souce ini ke dalam Form :Dim xls As New Excel.Application Dim xlsw As Excel.Workbook Dim xlsws As Excel.Worksheet Private Sub Command1_Click() Dim tmpstr, Path_LIST As String tmpstr = CDMod.ShowOpen(Me.hWnd, "Microsoft Office Excel 2003 ( *.XLS)" + vbNullChar + "*XLS;", "Microsoft Office Excel 2003") If tmpstr = "" Then Exit Sub Else Text1 = tmpstr End If End Sub Private Sub Command2_Click() 'Open file Set xlsw = xls.Workbooks.Open(Text1.Text) 'Menampilkan Aplikasi EXCEL xls.Visible = True 'sheet yang ditampilkan xlsw.Sheets("Sheet1").Select 'Set Lebar 1 cell xlsw.Application.Cells(1, 1).ColumnWidth = TSize.Text 'Set Tinggi 1 cell 'xlsw.Application.Cells(1, 1).RowHeight = TSize.Text Set xlsw = Nothing Set xls = Nothing End Sub Private Sub Command3_Click() 'Open file Set xlsw = xls.Workbooks.Open(Text1.Text) 'Menampilkan Aplikasi EXCEL xls.Visible = True 'set sheet yg digunakan xlsw.Sheets("Sheet1").Select 'Set Lebar Semua cell xlsw.Application.Cells.ColumnWidth = TSize.Text 'Set Tinggi Semua cell 'xlsw.Application.Cells.RowHeight = TSize.Text 'xlsw.Close False 'xls.Quit Set xlsw = Nothing Set xls = Nothing End Sub

Masukkan souce ini ke dalam Module dan ganti nama Module menjadi "CDMod" :'KPD-Team 1999 'URL: http://www.allapi.net 'E-Mail: KPDTeam@Allapi.com Public Const LF_FACESIZE = 32 Public Const MAX_PATH = 260 'ShowOpen/ShowSave flags: Public Const OFN_ALLOWMULTISELECT = &H200 Public Const OFN_CREATEPROMPT = &H2000 Public Const OFN_ENABLEHOOK = &H20 Public Const OFN_ENABLETEMPLATE = &H40 Public Const OFN_ENABLETEMPLATEHANDLE = &H80 Public Const OFN_EXPLORER = &H80000 Public Const OFN_EXTENSIONDIFFERENT = &H400 Public Const OFN_FILEMUSTEXIST = &H1000 Public Const OFN_HIDEREADONLY = &H4 Public Const OFN_LONGNAMES = &H200000 Public Const OFN_NOCHANGEDIR = &H8 Public Const OFN_NODEREFERENCELINKS = &H100000 Public Const OFN_NOLONGNAMES = &H40000 Public Const OFN_NONETWORKBUTTON = &H20000 Public Const OFN_NOREADONLYRETURN = &H8000 Public Const OFN_NOTESTFILECREATE = &H10000 Public Const OFN_NOVALIDATE = &H100 Public Const OFN_OVERWRITEPROMPT = &H2 Public Const OFN_PATHMUSTEXIST = &H800 Public Const OFN_READONLY = &H1 Public Const OFN_SHAREAWARE = &H4000 Public Const OFN_SHAREFALLTHROUGH = 2 Public Const OFN_SHARENOWARN = 1 Public Const OFN_SHAREWARN = 0 Public Const OFN_SHOWHELP = &H10 Public Const OFS_MAXPATHNAME = 128 'ChooseColor flags: Public Const CC_ANYCOLOR = &H100 Public Const CC_ENABLEHOOK = &H10 Public Const CC_ENABLETEMPLATE = &H20 Public Const CC_ENABLETEMPLATEHANDLE = &H40 Public Const CC_FULLOPEN = &H2 Public Const CC_PREVENTFULLOPEN = &H4 Public Const CC_RGBINIT = &H1 Public Const CC_SHOWHELP = &H8 Public Const CC_SOLIDCOLOR = &H80 'ChooseFont flags: Public Const CF_ANSIONLY = &H400& Public Const CF_APPLY = &H200& Public Const CF_SCREENFONTS = &H1 Public Const CF_PRINTERFONTS = &H2 Public Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS) Public Const CF_EFFECTS = &H100& Public Const CF_DSPTEXT = &H81 Public Const CF_ENABLEHOOK = &H8& Public Const CF_ENABLETEMPLATE = &H10& Public Const CF_ENABLETEMPLATEHANDLE = &H20& Public Const CF_FIXEDPITCHONLY = &H4000& Public Const CF_FORCEFONTEXIST = &H10000 Public Const CF_GDIOBJFIRST = &H300 Public Const CF_GDIOBJLAST = &H3FF Public Const CF_INITTOLOGFONTSTRUCT = &H40& Public Const CF_LIMITSIZE = &H2000& Public Const CF_NOFACESEL = &H80000 Public Const CF_NOSCRIPTSEL = &H800000 Public Const CF_NOSIMULATIONS = &H1000& Public Const CF_NOSIZESEL = &H200000 Public Const CF_NOSTYLESEL = &H100000 Public Const CF_NOVECTORFONTS = &H800& Public Const CF_NOVERTFONTS = &H1000000 Public Const CF_OWNERDISPLAY = &H80 Public Const CF_PRIVATEFIRST = &H200 Public Const CF_PRIVATELAST = &H2FF Public Const CF_SCALABLEONLY = &H20000 Public Const CF_SCRIPTSONLY = CF_ANSIONLY Public Const CF_SELECTSCRIPT = &H400000 Public Const CF_SHOWHELP = &H4& Public Const CF_TTONLY = &H40000 Public Const CF_USESTYLE = &H80& Public Const CF_WYSIWYG = &H8000 'PageSetupDlg flags Public Const PSD_DEFAULTMINMARGINS = &H0 Public Const PSD_DISABLEMARGINS = &H10 Public Const PSD_DISABLEORIENTATION = &H100 Public Const PSD_DISABLEPAGEPAINTING = &H80000 Public Const PSD_DISABLEPAPER = &H200 Public Const PSD_DISABLEPRINTER = &H20 Public Const PSD_ENABLEPAGEPAINTHOOK = &H40000 Public Const PSD_ENABLEPAGESETUPHOOK = &H2000 Public Const PSD_ENABLEPAGESETUPTEMPLATE = &H8000 Public Const PSD_ENABLEPAGESETUPTEMPLATEHANDLE = &H20000 Public Const PSD_INHUNDREDTHSOFMILLIMETERS = &H8 Public Const PSD_INTHOUSANDTHSOFINCHES = &H4 Public Const PSD_INWININIINTLMEASURE = &H0 Public Const PSD_MARGINS = &H2 Public Const PSD_MINMARGINS = &H1 Public Const PSD_NOWARNING = &H80 Public Const PSD_RETURNDEFAULT = &H400 Public Const PSD_SHOWHELP = &H800 'PrintDlg flags: Public Const PD_ALLPAGES = &H0 Public Const PD_COLLATE = &H10 Public Const PD_DISABLEPRINTTOFILE = &H80000 Public Const PD_ENABLEPRINTHOOK = &H1000 Public Const PD_ENABLEPRINTTEMPLATE = &H4000 Public Const PD_ENABLEPRINTTEMPLATEHANDLE = &H10000 Public Const PD_ENABLESETUPHOOK = &H2000 Public Const PD_ENABLESETUPTEMPLATE = &H8000 Public Const PD_ENABLESETUPTEMPLATEHANDLE = &H20000 Public Const PD_HIDEPRINTTOFILE = &H100000 Public Const PD_NONETWORKBUTTON = &H200000 Public Const PD_NOPAGENUMS = &H8 Public Const PD_NOSELECTION = &H4 Public Const PD_NOWARNING = &H80 Public Const PD_PAGENUMS = &H2 Public Const PD_PRINTSETUP = &H40 Public Const PD_PRINTTOFILE = &H20 Public Const PD_RETURNDC = &H100 Public Const PD_RETURNDEFAULT = &H400 Public Const PD_RETURNIC = &H200 Public Const PD_SELECTION = &H1 Public Const PD_SHOWHELP = &H800 Public Const PD_USEDEVMODECOPIES = &H40000 Public Const PD_USEDEVMODECOPIESANDCOLLATE = &H40000 'BrowseForFolder flags: Public Const BIF_RETURNONLYFSDIRS = &H1 ' For finding a folder to start document searching Public Const BIF_DONTGOBELOWDOMAIN = &H2 ' For starting the Find Computer Public Const BIF_STATUSTEXT = &H4 Public Const BIF_RETURNFSANCESTORS = &H8 Public Const BIF_BROWSEFORCOMPUTER = &H1000 ' Browsing for Computers. Public Const BIF_BROWSEFORPRINTER = &H2000 ' Browsing for Printers Public Const BIF_BROWSEINCLUDEFILES = &H4000 ' Browsing for Everything 'Error constants Public Const CDERR_DIALOGFAILURE = &HFFFF Public Const CDERR_FINDRESFAILURE = &H6 Public Const CDERR_GENERALCODES = &H0 Public Const CDERR_INITIALIZATION = &H2 Public Const CDERR_LOADRESFAILURE = &H7 Public Const CDERR_LOADSTRFAILURE = &H5 Public Const CDERR_LOCKRESFAILURE = &H8 Public Const CDERR_MEMALLOCFAILURE = &H9 Public Const CDERR_MEMLOCKFAILURE = &HA Public Const CDERR_NOHINSTANCE = &H4 Public Const CDERR_NOHOOK = &HB Public Const CDERR_REGISTERMSGFAIL = &HC Public Const CDERR_NOTEMPLATE = &H3 Public Const CDERR_STRUCTSIZE = &H1 'ShowHelp Enum Enum enumHelpState SW_HIDE = 0 SW_NORMAL = 1 SW_MAXIMIZE = 3 SW_MINIMIZE = 6 SW_SHOWDEFAULT = 10 End Enum 'Types Type POINTAPI X As Long Y As Long End Type Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Type OPENFILENAME lStructSize As Long hWndOwner As Long hInstance As Long lpstrFilter As String lpstrCustomFilter As String nMaxCustFilter As Long nFilterIndex As Long lpstrFile As String nMaxFile As Long lpstrFileTitle As String nMaxFileTitle As Long lpstrInitialDir As String lpstrTitle As String flags As Long nFileOffset As Integer nFileExtension As Integer lpstrDefExt As String lCustData As Long lpfnHook As Long lpTemplateName As String End Type Type PRINTDLG lStructSize As Long hWndOwner As Long hDevMode As Long hDevNames As Long hDC As Long flags As Long nFromPage As Integer nToPage As Integer nMinPage As Integer nMaxPage As Integer nCopies As Integer hInstance As Long lCustData As Long lpfnPrintHook As Long lpfnSetupHook As Long lpPrintTemplateName As String lpSetupTemplateName As String hPrintTemplate As Long hSetupTemplate As Long End Type Type PAGESETUPDLG lStructSize As Long hWndOwner As Long hDevMode As Long hDevNames As Long flags As Long ptPaperSize As POINTAPI rtMinMargin As RECT rtMargin As RECT hInstance As Long lCustData As Long lpfnPageSetupHook As Long lpfnPagePaintHook As Long lpPageSetupTemplateName As String hPageSetupTemplate As Long End Type Type CHOOSECOLOR lStructSize As Long hWndOwner As Long hInstance As Long rgbResult As Long lpCustColors As String flags As Long lCustData As Long lpfnHook As Long lpTemplateName As String End Type Type LOGFONT lfHeight As Long lfWidth As Long lfEscapement As Long lfOrientation As Long lfWeight As Long lfItalic As Byte lfUnderline As Byte lfStrikeOut As Byte lfCharSet As Byte lfOutPrecision As Byte lfClipPrecision As Byte lfQuality As Byte lfPitchAndFamily As Byte lfFaceName(LF_FACESIZE) As Byte End Type Type CHOOSEFONT lStructSize As Long hWndOwner As Long ' caller's window handle hDC As Long ' printer DC/IC or NULL lpLogFont As LOGFONT ' ptr. to a LOGFONT struct iPointSize As Long ' 10 * size in points of selected font flags As Long ' enum. type flags rgbColors As Long ' returned text color lCustData As Long ' data passed to hook fn. lpfnHook As Long ' ptr. to hook function lpTemplateName As String ' custom template name hInstance As Long ' instance handle of.EXE that ' contains cust. dlg. template lpszStyle As String ' return the style field here ' must be LF_FACESIZE or bigger nFontType As Integer ' same value reported to the EnumFonts ' call back with the extra FONTTYPE_ ' bits added MISSING_ALIGNMENT As Integer nSizeMin As Long ' minimum pt size allowed & nSizeMax As Long ' max pt size allowed if ' CF_LIMITSIZE is used End Type Type BROWSEINFO hWndOwner As Long pIDLRoot As Long pszDisplayName As Long lpszTitle As Long ulFlags As Long lpfnCallback As Long lParam As Long iImage As Long End Type Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hmem As Long) Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BROWSEINFO) As Long Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long Declare Function CHOOSECOLOR Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long Declare Function PRINTDLG Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As PRINTDLG) As Long Declare Function PAGESETUPDLG Lib "comdlg32.dll" Alias "PageSetupDlgA" (pPagesetupdlg As PAGESETUPDLG) As Long Declare Function CHOOSEFONT Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As CHOOSEFONT) As Long Declare Function GetFileTitleAPI Lib "comdlg32.dll" Alias "GetFileTitleA" (ByVal lpszFile As String, ByVal lpszTitle As String, ByVal cbBuf As Integer) As Integer Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long 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 Global OFName As OPENFILENAME, PD As PRINTDLG, PSD As PAGESETUPDLG, CC As CHOOSECOLOR Global CFont As CHOOSEFONT, BInfo As BROWSEINFO Dim CustomColors() As Byte 'Use the OR operator for multiple flags ' e.g. nFlags = CC_FULLOPEN Or CC_SOLIDCOLOR Public Function ShowColor(hWndOwner As Long, Optional nFlags As Long) As Long Dim i As Integer ReDim CustomColors(0 To 16 * 4 - 1) As Byte For i = LBound(CustomColors) To UBound(CustomColors) CustomColors(i) = 0 Next i CC.lStructSize = Len(CC) CC.hWndOwner = hWndOwner CC.hInstance = App.hInstance CC.lpCustColors = StrConv(CustomColors, vbUnicode) CC.flags = nFlags If CHOOSECOLOR(CC) <> 0 Then ShowColor = CC.rgbResult CustomColors = StrConv(CC.lpCustColors, vbFromUnicode) Else ShowColor = -1 End If End Function 'Use the vbNullChar character to seperate extensions in the filter ' e.g. sFilter = "Text Files (*.txt)" + vbNullChar + "*.txt" + "All Files (*.*)" + vbNullChar + "*.*" 'Use the OR operator for multiple flags ' e.g. nFlags = OFN_EXPLORER Or OFN_FILEMUSTEXIST Public Function ShowOpen(hWndOwner As Long, sFilter As String, sTitle As String, Optional nFlags As Long = OFN_EXPLORER) As String OFName.lStructSize = Len(OFName) OFName.hWndOwner = hWndOwner OFName.hInstance = App.hInstance OFName.lpstrFilter = sFilter OFName.lpstrFile = String(254, vbNullChar) OFName.nMaxFile = 255 OFName.lpstrFileTitle = String(254, vbNullChar) OFName.nMaxFileTitle = 255 OFName.lpstrTitle = sTitle OFName.flags = nFlags If GetOpenFileName(OFName) Then ShowOpen = StripTerminator(OFName.lpstrFile) Else ShowOpen = "" End If End Function 'Use the vbNullChar character to seperate extensions in the filter ' e.g. sFilter = "Text Files (*.txt)" + vbNullChar + "*.txt" + "All Files (*.*)" + vbNullChar + "*.*" 'Use the OR operator for multiple flags ' e.g. nFlags = OFN_EXPLORER Or OFN_FILEMUSTEXIST Public Function ShowSave(hWndOwner As Long, sFilter As String, sTitle As String, Optional nFlags As Long = OFN_EXPLORER) As String OFName.lStructSize = Len(OFName) OFName.hWndOwner = hWndOwner OFName.hInstance = App.hInstance OFName.lpstrFilter = sFilter OFName.lpstrFile = String(254, vbNullChar) OFName.nMaxFile = 255 OFName.lpstrFileTitle = String(254, vbNullChar) OFName.nMaxFileTitle = 255 OFName.lpstrTitle = sTitle OFName.flags = nFlags If GetSaveFileName(OFName) Then ShowSave = StripTerminator(OFName.lpstrFile) Else ShowSave = "" End If End Function 'Use the OR operator for multiple flags ' e.g. nFlags = PD_PAGENUMS Or PD_NONETWORKBUTTON Public Function ShowPrintDlg(hWndOwner As Long, Optional nFlags As Long) As Long PD.lStructSize = Len(PD) PD.hWndOwner = hWndOwner PD.hInstance = App.hInstance PD.flags = nFlags If PRINTDLG(PD) Then ShowPrintDlg = 0 Else ShowPrintDlg = -1 End If End Function 'Use the OR operator for multiple flags ' e.g. nFlags = PSD_DEFAULTMINMARGINS Or PSD_RETURNDEFAULT Public Function ShowPageSetupDlg(hWndOwner As Long, Optional nFlags As Long) As Long PSD.lStructSize = Len(PSD) PSD.hWndOwner = hWndOwner PSD.hInstance = App.hInstance PSD.flags = nFlags If PAGESETUPDLG(PSD) Then ShowPageSetupDlg = 0 Else ShowPageSetupDlg = -1 End If End Function 'Use the OR operator for multiple flags ' e.g. nFlags = CF_BOTH Or CF_WYSIWYG Public Function ShowFont(hWndOwner As Long, Optional nFlags As Long = CF_BOTH) As Long CFont.lStructSize = Len(CFont) CFont.hDC = Printer.hDC CFont.hInstance = App.hInstance CFont.hWndOwner = hWndOwner CFont.flags = nFlags If CHOOSEFONT(CFont) Then ShowFont = 0 Else ShowFont = -1 End If End Function 'Use the OR operator for multiple flags ' e.g. nFlags = BIF_BROWSEFORCOMPUTER Or BIF_BROWSEFORPRINTER Public Function BrowseForFolder(hWndOwner As Long, sTitle As String) As String Dim lpIDList As Long With BInfo .hWndOwner = hWndOwner .lpszTitle = lstrcat(sTitle, "") .ulFlags = BIF_RETURNONLYFSDIRS End With lpIDList = SHBrowseForFolder(BInfo) If lpIDList Then BrowseForFolder = String$(MAX_PATH, 0) SHGetPathFromIDList lpIDList, BrowseForFolder CoTaskMemFree lpIDList BrowseForFolder = StripTerminator(BrowseForFolder) End If End Function Public Function GetFileTitle(sFile As String) As String GetFileTitle = String(255, vbNullChar) GetFileTitleAPI sFile, GetFileTitle, 255 GetFileTitle = StripTerminator(GetFileTitle) End Function Public Function GetErrorString() As String Select Case CommDlgExtendedError Case CDERR_DIALOGFAILURE GetErrorString = "The dialog box could not be created." Case CDERR_FINDRESFAILURE GetErrorString = "The common dialog box function failed to find a specified resource." Case CDERR_INITIALIZATION GetErrorString = "The common dialog box function failed during initialization." Case CDERR_LOADRESFAILURE GetErrorString = "The common dialog box function failed to load a specified resource." Case CDERR_LOADSTRFAILURE GetErrorString = "The common dialog box function failed to load a specified string." Case CDERR_LOCKRESFAILURE GetErrorString = "The common dialog box function failed to lock a specified resource." Case CDERR_MEMALLOCFAILURE GetErrorString = "The common dialog box function was unable to allocate memory for internal structures." Case CDERR_MEMLOCKFAILURE GetErrorString = "The common dialog box function was unable to lock the memory associated with a handle." Case CDERR_NOHINSTANCE GetErrorString = "The ENABLETEMPLATE flag was set in the Flags member of the initialization structure for the corresponding common dialog box, but you failed to provide a corresponding instance handle." Case CDERR_NOHOOK GetErrorString = "The ENABLEHOOK flag was set in the Flags member of the initialization structure for the corresponding common dialog box, but you failed to provide a pointer to a corresponding hook procedure." Case CDERR_REGISTERMSGFAIL GetErrorString = "The RegisterWindowMessage function returned an error code when it was called by the common dialog box function." Case CDERR_NOTEMPLATE GetErrorString = "The ENABLETEMPLATE flag was set in the Flags member of the initialization structure for the corresponding common dialog box, but you failed to provide a corresponding template." Case CDERR_STRUCTSIZE GetErrorString = "The lStructSize member of the initialization structure for the corresponding common dialog box is invalid." Case Else GetErrorString = "Undefined error ..." End Select End Function Public Sub ShowHelp(hWndOwner As Long, sHelpFile As String, nShowState As enumHelpState) ShellExecute hWndOwner, vbNullString, sHelpFile, vbNullString, "C:\", nShowState End Sub Private Function StripTerminator(sInput As String) As String Dim ZeroPos As Integer ZeroPos = InStr(1, sInput, vbNullChar) If ZeroPos > 0 Then StripTerminator = Left$(sInput, ZeroPos - 1) Else StripTerminator = sInput End If End Function

Mendapatkan Value Tinggi (Height) Pada Row (A1) MS.Excel

PERSIAPAN
NO	REFERENCES			KETERANGAN
1.	Microsoft Excel 11.0 Object Library			Cara menambahkannya adalah pilih menu : Project-references. Office yg Digunakan MS 2003
PERSIAPAN			PROPERTIES
NO	CONTROL	PCS	NAME	VALUE	KETERANGAN
2.	TextBox	1	Text	""	kosongkan
3.	CommandButton	1	Caption	Height

Masukkan souce ini ke dalam Form :Dim xls As New Excel.Application Dim xlsw As Excel.Workbook Dim xlsws As Excel.Worksheet Private Sub Command1_Click() Set xlsw = xls.Workbooks.Open(App.Path & "\New Microsoft Excel Worksheet.xls") 'sheet yang ditampilkan xlsw.Sheets("Sheet1").Select 'Menampilkan Tinggi Pada Text1 Text1 = xlsw.Application.Cells(1, 1).Height xlsw.Close False xls.Quit Set xlsw = Nothing Set xls = Nothing End Sub

Excel ( Menampilkan Value Pada Kolom A1 )

Persiapan :
- Microsoft Office 2003
- 1 command button ( Name: Value )
- 1 textbox ( Name: text1 )

masukkan souce ini ke dalam form :

'keterangan
'menambahkan micosoft excell object
'caranya :
'buka Project-->References--> beri tanda centang pada microsoft excel

Dim xls As New Excel.Application
Dim xlsw As Excel.Workbook
Dim xlsws As Excel.Worksheet

Private Sub Command1_Click()

Set xlsw = xls.Workbooks.Open(App.Path & "\New Microsoft Excel Worksheet.xls")

'memilih sheet yang digunakan
xlsw.Sheets("Sheet1").Select

'menampilkan cell Text1.text
Text1.text = xlsw.Application.Cells(1, 1).Value

xlsw.Close False
xls.Quit
Set xlsw = Nothing
Set xls = Nothing

End Sub

Excel ( Merger / Unmerger)

Persiapan :
- Microsoft Office 2003
- 2 command button (Name: Merger , Name: Unmerger)
- 1 textbox ( Name: TCell , Text : A1:B1:C1 )