'Text Okuyucu

'Text Dosyasını Picture Box içinde
'Aşağıdan Yukarıya Kaydırarak gösteriyor
' - 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 Modül Ekleyin

'*** Form'un İçine Yazılacak Olanlar
' -----------------------------------------------------
Private TextLine() AsString
Private Scrolling AsBoolean
Private Alignment AsLong
Private t AsLong
Private Index AsLong
Private RText As RECT
Private RClip As RECT
Private RUpdate As RECT
PrivateSub 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 = "&Load txt file..."
Command1.Move 10, 320, 100, 25

Command2.Caption = "&Start"
Command2.Move 200, 320, 100, 25
Command2.Enabled = False

Command3.Caption = "S&top"
Command3.Move 310, 320, 100, 25

Check1.Caption = "L&oop"
Check1.Move 200, 350

With Picture1
SetRect RClip, 0, 1, .ScaleWidth, .ScaleHeight
SetRect RText, 0, .ScaleHeight, _
.ScaleWidth, .ScaleHeight + .TextHeight("")
EndWith

'Center Text (&H0 = Left, &H2 = Right, &H1 = Center)

Alignment = &H1

EndSub

PrivateSub Command2_Click()
Command1.Enabled = False
Scrolling = True
Index = 0
Call Scroll
EndSub

PrivateSub Command3_Click()
Scrolling = False
Command2.Enabled = True
EndSub

PrivateSub Form_Unload(Cancel AsInteger)
Scrolling = False'!
End
EndSub

PrivateSub Scroll()
Dim txt AsString
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)
EndIf
Index = Index + 1
EndIf
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
EndIf
DoEvents
Loop Until Scrolling = FalseOr Index > UBound(TextLine)
EndWith
If Check1 And Scrolling Then Command2 = True
Command1.Enabled = True
EndSub

PrivateSub Command1_Click()
CommonDialog1.Filter = "Text files (*.txt)|*.txt"
CommonDialog1.DefaultExt = "*.txt"
CommonDialog1.Flags = cdlOFNHideReadOnly Or _
cdlOFNPathMustExist Or _
cdlOFNOverwritePrompt Or _
cdlOFNNoReadOnlyReturn
CommonDialog1.DialogTitle = "Select a file"
CommonDialog1.CancelError = True
OnErrorGoTo CancelOpen
CommonDialog1.ShowOpen
DoEvents
MousePointer = vbHourglass
Dim srcFile AsString
Dim txtLine AsString
Dim FF AsInteger
FF = FreeFile
Open (CommonDialog1.FileName) ForInputAs #FF
WhileNot EOF(FF)
LineInput #FF , txtLine
srcFile = srcFile & txtLine & vbCrLf
Wend
Close #FF
IfTrim(Text1.Text) = ""ThenExitSub
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
ExitSub

CancelOpen:

If Err.Number <> 7 ThenExitSub
MousePointer = vbCustom
MsgBox"Unable To load file." & vbNewLine & vbNewLine & _
"Probably size exceeds TextBox maximum lenght (64Kb)", _
vbCritical, "Error"
EndSub



'*** Modüle Yazılacak Olanlar
'-----------------------------------------------------------

OptionExplicit
DeclareFunction GetTickCount Lib "kernel32" () AsLong
DeclareFunction SetRect Lib "user32" _
(lpRect As RECT, _
ByVal X1 AsLong, ByVal Y1 AsLong, _
ByVal X2 AsLong, ByVal Y2 AsLong) AsLong

DeclareFunction OffsetRect Lib "user32" _
(lpRect As RECT, _
ByVal X AsLong, _
ByVal Y AsLong) AsLong
DeclareFunction ScrollDC Lib "user32" _
(ByVal hdc AsLong, _
ByVal dx AsLong, ByVal dy AsLong, _
lprcScroll As RECT, _
lprcClip As RECT, _
ByVal hrgnUpdate AsLong, _
lprcUpdate As RECT) AsLong
DeclareFunction DrawText Lib "user32" Alias "DrawTextA" _
(ByVal hdc AsLong, _
ByVal lpStr AsString, _
ByVal nCount AsLong, _
lpRect As RECT, _
ByVal wFormat AsLong) AsLong
DeclareFunction SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd AsLong, _
ByVal wMsg AsLong, _
ByVal wParam AsLong, lParam As Any) _
AsLong
PublicConst EM_FMTLINES = &HC8
PublicType RECT
LeftAsLong
Top AsLong
RightAsLong
Bottom AsLong
EndType