Source Code VB

January 19, 2010

Save and Lost Text Files

Filed under: control — programmervb @ 5:18 pm

Sub LoadText(Lst As TextBox, file As String)
‘Call LoadText (Text1,”C:\Windows\System\Saved.txt”)
On Error GoTo error
Dim mystr As String
Open file For Input As #1
Do While Not EOF(1)
Line Input #1, a$
texto$ = texto$ + a$ + Chr$(13) + Chr$(10)
Loop
Lst = texto$
Close #1
Exit Sub
error:
X = MsgBox(“File Not Found”, vbOKOnly, “Error”)
End Sub

Sub SaveText(Lst As TextBox, file As String)
‘Call SaveText (Text1,”C:\Windows\System\Saved.txt”)
On Error GoTo error
Dim mystr As String
Open file For Output As #1
Print #1, Lst
Close 1
Exit Sub
error:
X = MsgBox(“There has been a error!”, vbOKOnly, “Error”)
End Sub

‘From:PulseWave

December 8, 2009

Limit Mouse

Filed under: forms — programmervb @ 3:48 pm

Option Explicit

Private Type RECT
left                 As Integer
top                  As Integer
right                As Integer
bottom               As Integer
End Type

Private Type POINT
x                    As Long
y                    As Long
End Type

Private Declare Sub ClipCursor Lib “user32″ (lpRect As Any)
Private Declare Sub GetClientRect Lib “user32″ (ByVal hWnd As _
Long, lpRect As RECT)
Private Declare Sub ClientToScreen Lib “user32″ (ByVal hWnd As _
Long, lpPoint As POINT)
Private Declare Sub OffsetRect Lib “user32″ (lpRect As RECT, _
ByVal x As Long, ByVal y As Long)

Public Sub LimitCursorMovement(ctl As Object)

Dim client           As RECT
Dim upperleft        As POINT
Dim lHwnd As Long
On Error Resume Next
lHwnd = ctl.hWnd
If lHwnd = 0 Then Exit Sub
GetClientRect ctl.hWnd, client
upperleft.x = client.left
upperleft.y = client.top
ClientToScreen ctl.hWnd, upperleft
OffsetRect client, upperleft.x, upperleft.y
ClipCursor client
End Sub

Public Sub ReleaseLimit()
‘Releases the cursor limits
‘Be sure to call on unloading the form
ClipCursor ByVal 0&
End Sub

Private Sub cmdNormal_Click()
ReleaseLimit
End Sub

Private Sub cmdSetLimit_Click()
LimitCursorMovement Me
End Sub

Private Sub Form_Load()
ReleaseLimit

End Sub

Private Sub Form_Unload(Cancel As Integer)
ReleaseLimit
End Sub

November 17, 2009

Re-Join File

Filed under: Uncategorized — programmervb @ 10:36 pm

Option Explicit

Private Const GENERIC_WRITE = &H40000000
Private Const GENERIC_READ = &H80000000
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const CREATE_ALWAYS = 2
Private Const OPEN_ALWAYS = 4
Private Const INVALID_HANDLE_VALUE = -1

Private Declare Function ReadFile Lib “kernel32″ _
(ByVal hFile As Long, lpBuffer As Any, _
ByVal nNumberOfBytesToRead As Long, _
lpNumberOfBytesRead As Long, _
ByVal lpOverlapped As Long) As Long

Private Declare Function CloseHandle Lib “kernel32″ _
(ByVal hObject As Long) As Long

Private Declare Function WriteFile Lib “kernel32″ _
(ByVal hFile As Long, lpBuffer As Any, _
ByVal nNumberOfBytesToWrite As Long, _
lpNumberOfBytesWritten As Long, _
ByVal lpOverlapped As Long) As Long

Private Declare Function CreateFile Lib _
“kernel32″ Alias “CreateFileA” _
(ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, _
ByVal lpSecurityAttributes As Long, _
ByVal dwCreationDisposition As Long, _
ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long) As Long

Private Declare Function FlushFileBuffers Lib “kernel32″ _
(ByVal hFile As Long) As Long

Public Function JoinFiles(ByVal inputFilename As String) As _
Boolean

Dim fReadHandle As Long
Dim fWriteHandle As Long
Dim fSuccess As Long
Dim lBytesWritten As Long
Dim lBytesRead As Long
Dim ReadBuffer() As Byte
Dim TotalCount As Long
Dim Count As Integer
Dim FileName As String
Dim ret As Integer

‘ Kalau file output sudah ada
If Dir(inputFilename) <> “” Then
ret = MsgBox(“File Output (” & inputFilename & _
“) sudah ada.” & vbCrLf & _
“Akan ditindih??”, _
vbYesNo + vbQuestion, “Konfirmasi”)
If ret = vbNo Then

JoinFiles = False
Exit Function
Else
Kill inputFilename
End If
End If

Count = 1
FileName = Dir(inputFilename & “.1″)

‘No files to join
If FileName = “” Then
JoinFiles = False
Exit Function
End If

Do While FileName <> “”
Count = Count + 1
FileName = Dir(inputFilename & “.” & Count)
Loop
TotalCount = Count – 1

‘ Buka file handle untuk file yang hendak ditulisi
fWriteHandle = CreateFile(inputFilename, _
GENERIC_WRITE Or GENERIC_READ, 0, 0, _
OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)

‘ Jika sukses lanjutkan
If fWriteHandle <> INVALID_HANDLE_VALUE Then

For Count = 1 To TotalCount
‘ Buka file yang dibaca
ReDim ReadBuffer(0 To FileLen(inputFilename & “.” & Count))
fReadHandle = CreateFile(inputFilename & “.” & Count, _
GENERIC_WRITE Or GENERIC_READ, 0, 0, _
OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)

‘ Jika pembacaan sukses, lanjutkan
If fReadHandle <> INVALID_HANDLE_VALUE Then
‘ Baca blok pertama
fSuccess = ReadFile(fReadHandle, ReadBuffer(0), _
UBound(ReadBuffer), lBytesRead, 0)

‘ Tulis blok ke file
fSuccess = WriteFile(fWriteHandle, ReadBuffer(0), _
UBound(ReadBuffer), lBytesWritten, 0)

If fSuccess <> 0 Then
‘ Harus di-flush
fSuccess = FlushFileBuffers(fWriteHandle)
Else
‘ Jika ada error, keluar
JoinFiles = False
Exit Function
End If

fSuccess = CloseHandle(fReadHandle)

Else
‘ Jika ada error, keluar
JoinFiles = False
Exit Function
End If

Next Count
Else
‘ Jika ada error, keluar
JoinFiles = False
Exit Function
End If

‘ Tutup file setelah ditulis
fSuccess = CloseHandle(fWriteHandle)
JoinFiles = True

End Function

Private Sub cmdExit_Click()
Unload Me
End Sub

Private Sub cmdSplit_Click()
If JoinFiles(txtFileName.Text) Then
MsgBox “File telah berhasil di-gabung!”
Else
MsgBox “File gagal di-gabung!”
End If
End Sub

cd tray open

Filed under: control — programmervb @ 10:28 pm

Set oWMP = CreateObject(“WMPlayer.OCX.7″)
Set colCDROMs = oWMP.cdromCollection

If colCDROMs.Count >= 1 Then

For i = 0 To colCDROMs.Count – 1
colCDROMs.Item(i).Eject
Next

End If


‘The next code opens only the CD-rw:
Set oWMP = CreateObject(“WMPlayer.OCX.7″)
Set colCDROMs = oWMP.cdromCollection

If colCDROMs.Count >= 1 Then

For i = 0 To colCDROMs.Count – 1
colCDROMs.Item(1).Eject
Next

End If


‘And this one ONLY the DVD-rw:
Set oWMP = CreateObject(“WMPlayer.OCX.7″)
Set colCDROMs = oWMP.cdromCollection

If colCDROMs.Count >= 1 Then

For i = 0 To colCDROMs.Count – 1
colCDROMs.Item(2).Eject
Next

End If

Older Posts »

Blog at WordPress.com.