Text Okuyucu Text Dosyasını Picture Box icinde Aşağıdan Yukarıya Kaydırarak gosteriyor
- 1 Adet PictureBox (name=Picture1, ClipControls=False)
- 1 Adet TextBox (name=Text1)
- 1 Adet CheckBox (name=Check1)
- 3 Adet command buttons (Command1, Command2 ve Command3)
- 1 Adet te Common Dialog Box (CommonDialog1) Yerleştirin
- Projeye 1 Adet Modul Ekleyin

Form'un İcine Yazılacak Olanlar
Kod:
Private TextLine() As String Private Scrolling As Boolean Private Alignment As Long Private t As Long Private Index As Long Private RText As RECT Private RClip As RECT Private RUpdate As RECT Private Sub Form_Load() Me.WindowState = 2 Me.Caption = "Text Okuyucu" Me.ScaleMode = vbPixels Me.Move Me.Left, Me.Top, Screen.TwipsPerPixelX * 425, _ Screen.TwipsPerPixelX * 400 Picture1.ScaleMode = vbPixels Picture1.Move 10, 10, 600, 300 Picture1.AutoRedraw = True Text1.Move 10, 10, 400 Text1.Visible = False Command1.Caption = "Txt Dosyası Yukle..." Command1.Move 10, 320, 105, 25 Command2.Caption = "Başlat" Command2.Move 200, 320, 100, 25 Command2.Enabled = False Command3.Caption = "Durdur" Command3.Move 310, 320, 100, 25 Check1.Caption = "Surekli Donsun" Check1.Move 200, 350 With Picture1 SetRect RClip, 0, 1, .ScaleWidth, .ScaleHeight SetRect RText, 0, .ScaleHeight, _ .ScaleWidth, .ScaleHeight + .TextHeight("") End With 'Center Text (&H0 = Left, &H2 = Right, &H1 = Center) Alignment = &H1 End Sub Private Sub Command2_Click() Command1.Enabled = False Scrolling = True Index = 0 Call Scroll End Sub Private Sub Command3_Click() Scrolling = False Command2.Enabled = True End Sub Private Sub Form_Unload(Cancel As Integer) Scrolling = False '! End End Sub Private Sub Scroll() Dim txt As String With Picture1 Do If GetTickCount - t > 25 Then t = GetTickCount If RText.Bottom < .ScaleHeight Then OffsetRect RText, 0, .TextHeight("") If Alignment = &H1 Then txt = Trim(TextLine(Index)) Else txt = TextLine(Index) End If Index = Index + 1 End If DrawText .hdc, txt, Len(txt), RText, Alignment OffsetRect RText, 0, -1 ScrollDC .hdc, 0, -1, RClip, RClip, 0, RUpdate Picture1.Line (0, .ScaleHeight - 1)-(.ScaleWidth, _ .ScaleHeight - 1), .BackColor End If DoEvents Loop Until Scrolling = False Or Index > UBound(TextLine) End With If Check1 And Scrolling Then Command2 = True Command1.Enabled = True End Sub Private Sub Command1_Click() CommonDialog1.Filter = "Text Dosyaları (*.txt)|*.txt" CommonDialog1.DefaultExt = "*.txt" CommonDialog1.Flags = cdlOFNHideReadOnly Or _ cdlOFNPathMustExist Or _ cdlOFNOverwritePrompt Or _ cdlOFNNoReadOnlyReturn CommonDialog1.DialogTitle = "Dosyayı Sec" CommonDialog1.CancelError = True On Error GoTo CancelOpen CommonDialog1.ShowOpen DoEvents MousePointer = vbHourglass Dim srcFile As String Dim txtLine As String Dim FF As Integer FF = FreeFile Open (CommonDialog1.FileName) For Input As #FF While Not EOF(FF) Line Input #FF, txtLine srcFile = srcFile & txtLine & vbCrLf Wend Close #FF If Trim(Text1.Text) = "" Then Exit Sub Command2.Enabled = True Text1 = srcFile SendMessage Text1.hwnd, EM_FMTLINES, True, 0 TextLine() = Split(Text1, vbCrLf) SendMessage Text1.hwnd, EM_FMTLINES, False, 0 Picture1.Cls MousePointer = vbCustom Exit Sub CancelOpen: If Err.Number 7 Then Exit Sub MousePointer = vbCustom MsgBox "Bilinmeyen Dosya." & vbNewLine & vbNewLine & _ "Dosyanın En Fazla (64)KB olmalıdır", _ vbCritical, "Hata" End Sub
Module Yazılacak Olanlar

Kod:
Option Explicit Declare Function GetTickCount Lib "kernel32" () As Long Declare Function SetRect Lib "user32" _ (lpRect As RECT, _ ByVal X1 As Long, ByVal Y1 As Long, _ ByVal X2 As Long, ByVal Y2 As Long) As Long Declare Function OffsetRect Lib "user32" _ (lpRect As RECT, _ ByVal X As Long, _ ByVal Y As Long) As Long Declare Function ScrollDC Lib "user32" _ (ByVal hdc As Long, _ ByVal dx As Long, ByVal dy As Long, _ lprcScroll As RECT, _ lprcClip As RECT, _ ByVal hrgnUpdate As Long, _ lprcUpdate As RECT) As Long Declare Function DrawText Lib "user32" Alias "DrawTextA" _ (ByVal hdc As Long, _ ByVal lpStr As String, _ ByVal nCount As Long, _ lpRect As RECT, _ ByVal wFormat As Long) As Long Declare Function SendMessage Lib "user32" Alias "SendMessageA" _ (ByVal hwnd As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, lParam As Any) _ As Long Public Const EM_FMTLINES = &HC8 Public Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type

__________________