Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

10 Kasım 2010 Çarşamba

Text Orientation by The SetWorldTransform Function




'UserForm1

'A) VBProject References List

'Name: VBA, Description: Visual Basic For Applications
'Name: Excel, Description: Microsoft Excel 11.0 Object Library
'Name: stdole, Description: OLE Automation
'Name: Office, Description: Microsoft Office 11.0 Object Library
'Name: MSForms, Description: Microsoft Forms 2.0 Object Library
'B) Addition Tools on UserForm1
'Image1, label1, Label2
Option Explicit
Private Declare Function GetDC Lib "User32.dll" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "User32.dll" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function SetGraphicsMode Lib "GDI32.dll" (ByVal hDC As Long, ByVal iMode As Long) As Long
Private Declare Function GetWorldTransform Lib "GDI32.dll" (ByVal hDC As Long, ByRef lpXform As XForm) As Long
Private Declare Function SetWorldTransform Lib "GDI32.dll" (ByVal hDC As Long, ByRef lpXform As XForm) As Long
Private Declare Function TextOut Lib "GDI32.dll" Alias "TextOutA" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Type XForm

Prm1 As Single 'Text right to left and chr width
Prm2 As Single 'Text horizontal orientation degrees
Prm3 As Single 'Text vertical orientation degrees
Prm4 As Single
'Text chr height
Prm5 As Single 'X preposition
Prm6 As Single
'Y preposition
End Type
Private PlpXform As XForm, OlpXform As XForm
Private OldGM As Long
Private DrawDC As Long
Private Const DemoText As String = "[PBİD®] Program - Bütçeleme & İzleme - Değerlendirme"
'PBİD: Program - Budgeting & Monitoring – Evaluation

Private Apsis As Double, Ordinat As Double, En As Double, Boy As Double
Private i As Single, ii As Single
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD®] Text Orientation by The SetWorldTransform Function"
Call EkranDüzenle
End Sub
Private Sub UserForm_Click()

On Error Resume Next
For i = -6 To 6 Step 0.1
Me.Repaint
Call TextOrientation(i, 0.001, 0, 6, Apsis, Ordinat)
For ii = 1 To 600
DoEvents
Next ii
Next i
Me.Repaint
Call TextOrientation(-1, 0.001, 0, 6, Apsis, Ordinat)
DoEvents
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

On Error Resume Next
Me.Repaint
Apsis = VBA.Round(X / 0.748, 0)
Ordinat = VBA.Round(Y / 0.748, 0)
Call TextOrientation(1, 0.001, 0, 6, Apsis, Ordinat)
DoEvents
End Sub
Private Sub TextOrientation(A, B, C, D, E, F)

On Error Resume Next
DrawDC = GetDC(FindWindow(vbNullString, Me.Caption))
OldGM = SetGraphicsMode(DrawDC, 2)
Call GetWorldTransform(DrawDC, OlpXform)
With PlpXform
.Prm1 = A
.Prm2 = B
.Prm3 = C
.Prm4 = D
.Prm5 = E
.Prm6 = F
End With
If (SetWorldTransform(DrawDC, PlpXform)) Then
Call TextOut(DrawDC, 0, 0, DemoText, Len(DemoText))
Call SetWorldTransform(DrawDC, OlpXform)
End If
Call SetGraphicsMode(DrawDC, OldGM)
Call ReleaseDC(FindWindow(vbNullString, Me.Caption), DrawDC)
End Sub
Private Sub EkranDüzenle()

On Error Resume Next
With Me
.Height = 300
.Width = 480
'.Picture = LoadPicture("C:\Documents and Settings\Administrator\Belgelerim\Mustafa ULUSARAÇ\VectorBackround.jpg")
.Picture = Resim(URL1)
.PictureAlignment = fmPictureAlignmentTopLeft
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
.BackColor = vbWhite
With Image1
.Left = 6
.Top = 6
.Height = 24
.Width = 24
.BorderColor = vbWhite
.BorderStyle = fmBorderStyleSingle
.BackStyle = fmBackStyleTransparent
'.Picture = LoadPicture("C:\Documents and Settings\Administrator\Belgelerim\Mustafa ULUSARAÇ\PBİD.ico")
.Picture = Resim(URL2)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
End With
With Label1
.Top = 6
.Left = 36
.Height = 12
.Width = 228
.AutoSize = False
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.Caption = "Mustafa ULUSARAÇ"
.Font.Bold = True
.ForeColor = vbBlue
.SpecialEffect = fmSpecialEffectFlat
.TextAlign = fmTextAlignLeft
End With
With Label2
.Top = 18
.Left = 36
.Height = 12
.Width = 228
.AutoSize = False
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleNone
.Caption = "01ulusarac@superonline.com"
.Font.Bold = True
.ForeColor = vbBlue
.SpecialEffect = fmSpecialEffectFlat
.TextAlign = fmTextAlignLeft
End With
End With
End Sub


'Module1

Option Explicit
Public Declare Function CLSIDFromString Lib "ole32" (ByVal lpstrCLSID As Long, lpCLSID As Any) As Long
Public Declare Function OleLoadPicturePath Lib "oleaut32" (ByVal szURLorPath As Long, ByVal punkCaller As Long, ByVal dwReserved As Long, ByVal clrReserved As OLE_COLOR, ByRef riid As Any, ByRef ppvRet As Any) As Long
Public IPic(15) As Byte
Public Const ClsID As Variant = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
'It may take a few seconds, please wait.

Public URL As String
Public Const URL1 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S7rn6KHVfNI/AAAAAAAACRs/fxVMg9YGzb4/s1600/VectorBackround.jpg"
'Microsoft Office Excel® Kod Kılavuzu [UserFormBackround]

Public Const URL2 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S78EbvJyhRI/AAAAAAAACS0/txbOQ1qubg8/s1600/PB%C4%B0D_jpg.jpg" 'Microsoft Office Excel® Kod Kılavuzu [PBİD Icon]
Sub FormAç() 'Open UserForm
On Error Resume Next
UserForm1.Show 0
End Sub
Public Function Resim(URL) As Picture
'Picture load frome web address...

On Error Resume Next
CLSIDFromString StrPtr(ClsID), IPic(0)
OleLoadPicturePath StrPtr(URL), 0&, 0&, 0&, IPic(0), Resim
End Function
'Sub ReferecesList()

' Dim Eleman, ElemanNo
' Sheets("ReferencesList").Select
' ElemanNo = 1
' For Each Eleman In ThisWorkbook.VBProject.References
' Cells(ElemanNo, 1) = "Name: "
' Cells(ElemanNo, 2) = Eleman.Name
' Cells(ElemanNo, 3) = ", Description: "
' Cells(ElemanNo, 4) = Eleman.Description
' Cells(ElemanNo, 5) = ", FullPath: "
' Cells(ElemanNo, 6) = Eleman.FullPath
' Cells(ElemanNo, 7) = ", Guid: "
' Cells(ElemanNo, 8) = Eleman.GUID
' Cells(ElemanNo, 9) = ", Major: "
' Cells(ElemanNo, 10) = Eleman.major
' Cells(ElemanNo, 11) = ", Minor: "
' Cells(ElemanNo, 12) = Eleman.minor
' ElemanNo = ElemanNo + 1
' Next Eleman
'End Sub

Blog Arşivi

Bu gadget'ta bir hata oluştu

Bu Blogda Ara

Contributor

Contributor
Mustafa ULUSARAÇ İstanbul, TÜRKİYE
free counters
T. C. Central Bank Indicative Exchange Rates
Currency Exchange Rate Widget,Currency Converter Widget
Borsa İstanbul