Announcement

Announcement Module
Collapse
No announcement yet.

POST, Analise dan Share Code di sini - VBers

Page Title Module
Move Remove Collapse
This is a sticky topic.
X
X
Conversation Detail Module
Collapse
  • Filter
  • Time
  • Show
Clear All
new posts

  • POST, Analise dan Share Code di sini - VBers

    Gmana kalo thread ini jd code bank vb di chip forums ??
    POST, Analise dan Share Code di sini
    Last edited by positive+; 20-10-2005, 01:18.

  • #2
    Re: POST, Analise dan Share Code di sini - VBers

    ChangeDatabasePassword
    Database Utility - Ms. Access Database
    Ms. ADO 2.5 Ref

    Full Source Code :
    Code:
    Option Explicit
    
    Const NL = vbNewLine
    Dim Con As Connection
    
    Function file_exist(iFile As String) As Boolean
    Dim a As String
        file_exist = False
        a = Len(Dir(iFile, 0 Or 1 Or 2 Or 32))
        If a > 0 Then file_exist = True
    End Function
    Function secure(iText As String) As String
        iText = Trim(iText)
        secure = Replace(Replace(iText, "'", "`"), "[", "")
    End Function
    Function Change_Pass(Dbpath As String, _
                         OldPass As String, _
                         NewPass As String) As Boolean
    On Error GoTo Junk
    Dim mProv As String, mSql As String
        Change_Pass = False
        If file_exist(Dbpath) = True Then
           mProv = "provider=microsoft.jet.oledb.4.0;Data Source=" & Dbpath
           mSql = "alter database password " & NewPass & " " & OldPass
           Set Con = New Connection
           Con.Mode = adModeShareExclusive
           Con.Open mProv & ";Jet OLEDB:Database Password=" & OldPass & ";"
           Con.Execute mSql
           Con.Close
           Set Con = Nothing
           Change_Pass = True
           Exit Function
        Else
           MsgBox "Database file not found at : " & NL & _
                  Dbpath & NL & "Please check the path again", 0 + 64, "File Not Found"
           Exit Function
        End If
    Junk:
        If Err.Number <> 0 Then
           MsgBox Err.Description, 0 + 48, "Err Found"
           Set Con = Nothing
           Exit Function
        End If
    End Function
    Private Sub Form_Load()
        Move (Screen.Width - Width) / 2, (Screen.Height - Height) / 3
        tNew.TabIndex = 0
    End Sub
    Private Sub cBatal_Click()
        Unload Me
        Set Form1 = Nothing
    End Sub
    Private Sub cUbah_Click()
    Dim sPath As String, sNew As String, sOld As String, ok As Boolean
        sPath = App.Path & "\" & "Test.mdb"
        sNew = secure(tNew.Text)
        sOld = secure(tOld.Text)
        ok = Change_Pass(sPath, sOld, sNew)
        If ok = True Then
           MsgBox "Changes Succeeded ... ", 0 + 64, "Succeeded"
        End If
    End Sub
    Last edited by positive+; 21-10-2005, 05:24.

    Comment


    • #3
      Re: POST, Analise dan Share Code di sini - VBers

      DatabaseTips
      Menampilkan Record - Undocumented Recordset Property
      same functionality with Fields Value Property but more faster

      code
      Code:
      Dim Rs As New Recordset
      Rs.Open "select * from Publishers;", Con, 1, 2
      '/ ref. dengan index column
      mvar = Rs.Collect(1)
      '/ ref. dengan nama column
      mvar = Rs.Collect("Name")
      Last edited by positive+; 21-10-2005, 05:21.

      Comment


      • #4
        Re: POST, Analise dan Share Code di sini - VBers

        TextBox tip.....
        clear textbox on form.....

        Code:
        For Each cntl In Form1
            If TypeOf cntl Is TextBox Then cntl.Text = ""
        Next

        Comment


        • #5
          Re: POST, Analise dan Share Code di sini - VBers

          Blinking label....

          Code:
          Dim lBlink as Boolean
          
          Private Sub Timer1_Timer()
          
          Label1.Visible = lBlink
          
          Timer1.Interval = 500
             If Label1.Visible = False Then
             lBlink = True 
               Else
             Label1.Visible = True
             lBlink = False
             End If
          
          End Sub
          maap masi dalam tahap belajar.... mohon bimbingannya......

          Comment


          • #6
            Re: POST, Analise dan Share Code di sini - VBers

            InputOnlyNumber
            Block user input utk selain angka

            Dengan menggunakan Function
            Code:
            
            '// No Message appear to user, but they will know what should they do
            '// bila ingin user tidak dapat meng-inputkan angka, jgn beri pesan apa2
            '// Just Block it ... ;) 
            Function BLOCK_KEY(sAscii As Integer) As Integer
                Select Case sAscii
                       Case 13
                            BLOCK_KEY = sAscii '/ perbolehkan {ENTER}
                       Case 32
                            BLOCK_KEY = sAscii '/ perbolehkan {SPACE}
                       Case 8
                            BLOCK_KEY = sAscii '/ perbolehkan {BACKSPACE}
                       Case 44
                            BLOCK_KEY = sAscii '/ perbolehkan {,} Comma
                       Case 46
                            BLOCK_KEY = sAscii '/ perbolehkan {.} Titik
                       Case 48 To 57
                            BLOCK_KEY = sAscii '/ perbolehkan {NUMBER}
                       Case Else
                            BLOCK_KEY = 0      '/ Selain dr kriteria di atas block input
                End Select
            End Function
            
            Private Sub Text1_KeyPress(KeyAscii As Integer)
            '// cara penggunaan - usage
                KeyAscii = BLOCK_KEY(KeyAscii)
            End Sub
            
            Dengan menggunakan IsNumeric Function
            Code:
            
            '// ini akan sll menampilkan Pesan ke user utk menginputkan angka
            '// this is do the job, but not user friendly ... thought ;) 
            Private Sub Text1_KeyPress(KeyAscii As Integer)
                If Not IsNumeric(Chr$(KeyAscii)) = True Then
                   MsgBox "Please input numerical values", 0 + 48, "Message"
                   KeyAscii = 0
                End If
            End Sub
            
            Last edited by positive+; 21-10-2005, 05:23.

            Comment


            • #7
              Re: POST, Analise dan Share Code di sini - VBers

              DateManipulation

              Code:
              
              Option Explicit
              
              Const NL = vbNewLine
              '// Now --> Current system time
              Private Sub Command1_Click()
              Dim Buffer As String
                  Buffer = Buffer & "Short date -> " & Format(Now, "short date") & NL
                  Buffer = Buffer & "Long Date -> " & Format(Now, "long date") & NL
                  Buffer = Buffer & "Medium Date -> " & Format(Now, "medium date") & NL
                  Buffer = Buffer & "Year -> " & Year(Now) & NL
                  Buffer = Buffer & "Month -> " & Month(Now) & NL
                  Buffer = Buffer & "Day -> " & Day(Now) & NL
                  Buffer = Buffer & "Month in Long Date Format -> " & Format(Now, "mmmm") & NL
                  Buffer = Buffer & "Day in Long Date Format -> " & Format(Now, "dddd")
                  MsgBox Buffer
              End Sub
              
              Last edited by positive+; 21-10-2005, 05:24.

              Comment


              • #8
                Re: POST, Analise dan Share Code di sini - VBers

                Hi Harno, mari kita analise code kamu yg ini ( please, no offence )

                Code:
                
                Private Sub Timer1_Timer()
                '// ini tidak akan pernah di-eksekusi, bila property Interval Timer pd waktu design _
                    tetap pada 0
                 
                   Label1.Visible = lBlink
                   '// bila ingin Timer Interval tetap pd 500 ( 0.5 detik )
                   Timer1.Interval = 500 '// mengapa ini hrs selalu di-update ?? bukankah lebih baik ditetapkan lgs pd saat design ??
                   '// bila ingin Timer Interval di atur dlm coding, Tempatkan -> Timer1.Interval = 500 <- pd event Form_Load
                   If Label1.Visible = False Then
                      lBlink = True
                   Else
                      'Label1.Visible = True <-- NOW WE REMOVE THIS LINE
                      '// yg kita lakukan hanya update True/False dari var. Boolean lBlink
                      '// dgn bgt ini akan sll di-eksekusi oleh line ini -> Label1.Visible = lBlink
                      lBlink = False
                   End If
                   
                End Sub
                
                Now, i would prefer to do this

                Code:
                
                Option Explicit
                
                Dim lBlink As Boolean
                
                Private Sub Form_Load()
                    Timer1.Interval = 500 '// set interval ( 0.5 detik )
                End Sub
                Private Sub Timer1_Timer()
                   lBlink = Not lBlink '// update Boolean Value for this Varible tiap 0.5 detik
                   Label1.Visible = lBlink
                End Sub
                
                Happy coding ...
                Last edited by positive+; 20-10-2005, 21:58.

                Comment


                • #9
                  Re: POST, Analise dan Share Code di sini - VBers

                  SHELLFUNCTION: Menjalankan executable program - basic usage

                  sample code

                  Code:
                  
                  Private Sub Command1_Click()
                      Shell "explorer", vbNormalFocus '// jalankan Explorer
                      Shell "explorer C:\", vbNormalFocus '// jalankan Explorer dgn memberi parameter path C:\
                      Shell "explorer mailto:", vbNormalFocus '// email
                      Shell "cmd", vbNormalFocus '// command prompt
                      Shell "control", vbNormalFocus '// control panel
                  End Sub
                  
                  Last edited by positive+; 21-10-2005, 05:25.

                  Comment


                  • #10
                    Re: POST, Analise dan Share Code di sini - VBers

                    FileManipulation
                    Read File Content - Noobs

                    Code:
                    
                    Option Explicit
                    
                    'Form dgn sebuah Textbox ( Set property Multiline = True,Scrollbar = 2 - Vertical _
                     dan sebuah CommandButton
                    
                    Enum OpenType
                         ByAscii
                         ByBinary
                    End Enum
                    
                    Function OpenFile(mFile As String, iType As OpenType, Obj As TextBox)
                    'Description : Read File contents _
                     mFile       : File Path yang akan dibaca _
                     iType       : Tipe Pembacaan ( Ascii / Binary ) _
                     Obj         : ByRef Parameter, Isikan dgn nama dr object
                    Dim iContent As String, buff As String
                        If mFile = "" Then Exit Function
                        Select Case iType
                               Case ByAscii
                                    Open mFile For Input As #1
                                         Do Until EOF(1) '// loop s/d end of file
                                            Line Input #1, buff '// fill buffer
                                            iContent = iContent & buff
                                         Loop
                                    Close #1
                                    Obj.Text = iContent '// show result
                               Case ByBinary
                                    Open mFile For Binary Access Read As #1
                                         iContent = Space(Fix(LOF(1))) '// create space buffer
                                         Get #1, , iContent '// get contents of file
                                    Close #1
                                    Obj.Text = iContent '// show result
                        End Select
                    End Function
                    Private Sub Command1_Click()
                    'Usage :
                         OpenFile "C:\Logfile.txt", ByBinary, Text1
                    End Sub
                    
                    Last edited by positive+; 21-10-2005, 05:26.

                    Comment


                    • #11
                      Re: POST, Analise dan Share Code di sini - VBers

                      Originally posted by positive+
                      Hi Harno, mari kita analise code kamu yg ini ( please, no offence )
                      santai aja....

                      Code:
                      
                      mengganti jam dan tanggal system....
                      
                      Private Sub Command1_Click()
                      Dim myTime
                      myTime = Text1.Text
                      Time = myTime
                      End Sub
                      
                      Private Sub Command2_Click()
                      Dim Mydate
                      Mydate = Text2.Text
                      Date = Mydate
                      End Sub
                      

                      Comment


                      • #12
                        Re: POST, Analise dan Share Code di sini - VBers

                        Mmm, just to remind us
                        please make some conversation here if there's a code that need to be analise, or there's somethin else that u think should get a critic's, please speak here too, and show us a better one.
                        thought, every code has been written with a various logic maybe you got a better one to shared, and we can learn something ... that still we don't know or miss. Thx

                        bila ada pendapat, critic's atau analise yg ingin temen2 share d sini, please do it ... lg pula kitakan sama2 lg belajar

                        My Best Regard, Positive+
                        Last edited by positive+; 21-10-2005, 23:07.

                        Comment


                        • #13
                          Re: POST, Analise dan Share Code di sini - VBers

                          API ( Application Programming Interface )
                          Using Rectangle Function

                          Code:
                          Option Explicit
                          
                          Private Declare Function Rectangle Lib "gdi32" _
                                  (ByVal hdc As Long, ByVal X1 As Long, _
                                  ByVal Y1 As Long, ByVal X2 As Long, _
                                  ByVal Y2 As Long) As Long
                                  
                          '=============================================================================
                          'Parameter Description :
                          '=============================================================================
                          ' hdc
                          'Identifies the device context.
                          ' X1
                          'Specifies the logical x-coordinate of the upper-left corner of the rectangle.
                          ' Y1
                          'Specifies the logical y-coordinate of the upper-left corner of the rectangle.
                          ' X2
                          'Specifies the logical x-coordinate of the lower-right corner of the rectangle.
                          ' Y2
                          'Specifies the logical y-coordinate of the lower-right corner of the rectangle.
                          '=============================================================================
                                  
                          Dim mSize As Long '/ size rect
                          
                          Sub Create_Grid()
                          Dim j As Long, jj As Long
                          Dim px As Long, py As Long
                              px = ScaleWidth + mSize '/ width to draw
                              py = ScaleHeight + mSize '/ height to draw
                              Cls '/ clear form
                              ' height and width Rectangle = mSize
                              For j = 0 To px Step mSize '/ loop for X values
                                  For jj = 0 To py Step mSize '// loop for Y values
                                      Rectangle Me.hdc, j, jj, 0, 0 '// draw rect
                                  Next
                              Next
                              CurrentX = ScaleWidth - 80
                              CurrentY = 25
                              Print mSize
                          End Sub
                          Sub Initialize()
                              ScaleMode = vbPixels
                              BackColor = &H0&
                              ForeColor = &H8000&
                              FontSize = 25
                              FontBold = True
                              mSize = 5
                          End Sub
                          Private Sub Form_Load()
                              Initialize 'setup form and mSize default value
                              WindowState = 2 '/ maximized form
                          End Sub
                          Private Sub Command1_Click()
                              mSize = mSize + 5 '/ increase mSize value
                              Create_Grid
                          End Sub
                          Private Sub Command2_Click()
                              If mSize = 5 Then Exit Sub
                              mSize = mSize - 5 '/ decrease mSize value
                              Create_Grid
                          End Sub
                          Private Sub Command3_Click()
                              Unload Me
                              Set Form1 = Nothing
                          End Sub
                          Sample proj. dlm ( *.zip ) File
                          Have fun, Positive+

                          Comment


                          • #14
                            Re: POST, Analise dan Share Code di sini - VBers

                            Utilities ::.
                            Create Word Document from program

                            Code:
                            Option Explicit
                            
                            'reference : Microsoft Word 10.0 Object Library _
                                         this ref. exist if you've install Office
                                         
                            'a form with Command Button called Command1 and One Textbox called Text1
                            
                            Sub AddToWord(iContents As String, _
                                          iFileName As String)
                                          
                            Dim w As New Word.Application
                            
                                w.Documents.Add '// add new document
                                w.Selection.TypeText (iContents) '// write this to current doc that has been open
                                w.ChangeFileOpenDirectory (App.Path) '// skrg kita buka Dialog Window dgn current project path 
                                
                                
                                w.ActiveDocument.SaveAs FileName:=iFileName & ".doc", _  '// save the file name same with iFilename parameter value
                                FileFormat:=wdFormatDocument, LockComments:=False, _ '// this, till end set the document properties
                                Password:="", _
                                AddToRecentFiles:=True, WritePassword:="", _
                                ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
                                SaveNativePictureFormat:=False, SaveFormsData:=False, _
                                SaveAsAOCELetter:=False
                                
                                w.ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
                                w.Application.Quit
                                
                                Set w = Nothing '// destroy object from memory
                            End Sub
                            Private Sub Command1_Click()
                                AddToWord Text1.Text, "Test3"
                            End Sub
                            hope it's usefull
                            Last edited by positive+; 23-10-2005, 03:43.

                            Comment


                            • #15
                              Re: POST, Analise dan Share Code di sini - VBers

                              plissss, analise this code
                              n tell me where I've done wrong!!

                              Code:
                              Dim Report As New CrystalReport1
                              
                              Private Sub Form_Load()
                              Screen.MousePointer = vbHourglass
                              CRViewer1.ReportSource = Report
                              Screen.MousePointer = vbDefault
                              
                                  Select Case FrmRep.CmbFilter.ListIndex
                                      Case 0
                                          Report.RecordSelectionFormula = "{Quatity.Date} in DateTime (" & FrmRep.TxtTh.Text & "," & FrmRep.CmbBln.Text & "," & FrmRep.CmbTgl.Text & ") to DateTime (" & FrmRep.TxtTh1.Text & "," & FrmRep.CmbBln1.Text & "," & FrmRep.CmbTgl1.Text & ")"
                                          CRViewer1.ViewReport
                                      Case 1
                                          Report.SQLQueryString = "select * from quatity order by draw_no" 'sort report ascending with draw_no field
                                          CRViewer1.ViewReport
                                      Case 2
                                          Report.SQLQueryString = "select * from quatity order by customer" 'sort report ascending with customer field
                                          CRViewer1.ViewReport
                                      Case 3
                                          Report.SQLQueryString = "select * from quatity order by proses" 'sort report ascending with proses field
                                          CRViewer1.ViewReport
                                      Case 4
                                          Report.SQLQueryString = "select * from quatity order by job_no" 'sort report ascending with job_no field
                                          CRViewer1.ViewReport
                                      Case 5
                                          Report.SQLQueryString = "select * from quatity order by opt_id" 'sort report ascending with opt_id field
                                          CRViewer1.ViewReport
                                  End Select
                                  
                              End Sub
                              
                              Private Sub Form_Resize()
                              CRViewer1.Top = 0
                              CRViewer1.Left = 0
                              CRViewer1.Height = ScaleHeight
                              CRViewer1.Width = ScaleWidth
                              
                              End Sub
                              code ini maksudnya untuk menampilkan report dengan sorting pada field tertentu, pi ga jalan2
                              dimana letak kesalahannya??

                              Comment

                              Working...
                              X