Text okuyucu


Visual Basic ve .NET Framework    Visual Basic ve .NET Framework İle İlgili Paylaşım Kategorisi

Yazar: ByClxon    0 Yorum    87 Görüntüleme
  • 0 Oy - 0 Yüzde

Paylaşım Tarihi: 11.05.2016, 22:42:21 #1
ByClxon SEA !
Efsane Üye
Status: Çevrimdışı Yorum Sayısı:1,020 Konu Sayısı:444 Üyelik Tarihi:07.01.2016 Rep Puanı: 664

'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.LeftMe.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 AsLongByVal Y1 AsLong, _
ByVal X2 AsLongByVal Y2 AsLongAsLong

DeclareFunction OffsetRect Lib "user32" _
(lpRect As RECT, _
ByVal X AsLong, _
ByVal Y AsLongAsLong
DeclareFunction ScrollDC Lib "user32" _
(ByVal hdc AsLong, _
ByVal dx AsLongByVal 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 AsLongAsLong
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

Kullanıcı İmzası
#fenerbahçeA.A.K.
İmage
İletişim İçin Facebook;

linkleri görmek için giriş yapmanız. Yada üye olmanız gerekir.


Öfkemiz sarsın her yanı, bozkurtlar yürüye yürüye
Dökülsün düşmanın kanı, yaşasın ırkçı TÜRKİYE!

Taşında gözü olanın yurduna MEZAR kazacağız
Hainin, soysuzun, döneğin alnına VATAN yaazcağız
Hainin, soysuzun alnına YAŞASIN TURAN yazacağız!



İmage






 

         








Aradığınızı Bulamadınız Mı ?

Konuyu görüntüleyenler:
1 Misafir