تغییر پوزیشن عنوان فرم

[M.T.P]

با سلام :قلب:
یادمه یه بار یه Theme واسه ویندوز نصب کردم که موقعیت عنوان فرم ها رو به وسط میاورد.
از دوستان کسی نحوه تغییر پوزیشن Caption فرم رو به وسط یا راست یا چپ(در صورت راست یا وسط بودن) بلده؟ :متفکر:
نکته: بدونه Right to left فرم.

[Babak.Hassanpour]

یک لیبل بزارید روی فرم و اینم کد هاش:



Dim i As Integer 'size of space
Dim iCap As Integer 'size of caption
Private Const txt = "This is the test" 'form caption text

Private Sub Form_Load()
With Label1
.AutoSize = True
.FontName = "MS Sans Serif"
.FontBold = True
.FontSize = 8
.Caption = " "
i = .Width - 15
.Caption = txt
iCap = .Width - 15
.Visible = False
End With
End Sub

Private Sub Form_Resize()
If WindowState <> vbMinimized Then
If Width < iCap + 1300 Then Width = (iCap + 1300)
Caption = String((Width - (iCap + 1300)) / (2 * i), " ") & txt
End If
End Sub

[Babak.Hassanpour]

اینم هست :


Option Explicit
'Example submitted by Steffen Bracke to www.allapi.net
'adapted by Cimperiali
'This code retrieves information about the fonts
'used in the window menus and captions

Const SPI_GETNONCLIENTMETRICS = 41
Const LF_FACESIZE = 32
Private Type LOGFONT
lfHeight As Long
lfEscapement As Long
lfUnderline As Byte
lfStrikeOut As Byte
lfWidth As Long
lfWeight As Long
lfItalic As Byte
lfCharSet As Byte
lfClipPrecision As Byte
lfOutPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfOrientation As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type

Private Type NONCLIENTMETRICS
cbSize As Long
iBorderWidth As Long
iScrollWidth As Long
iScrollHeight As Long
iCaptionWidth As Long
iCaptionHeight As Long
lfCaptionFont As LOGFONT
iSMCaptionWidth As Long
iSMCaptionHeight As Long
lfSMCaptionFont As LOGFONT
iMenuWidth As Long
iMenuHeight As Long
lfMenuFont As LOGFONT
lfStatusFont As LOGFONT
lfMessageFont As LOGFONT
End Type

Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long

Private Sub LastError()
Dim Buffer As String
Buffer = Space(200)
SetLastError ERROR_BAD_USERNAME
FormatMessage FORMAT_MESSAGE_FROM_SYSTEM, ByVal 0&, GetLastError, LANG_NEUTRAL, Buffer, 200, ByVal 0&
MsgBox Buffer
End Sub

Private Sub Command1_Click()
Dim ncm As NONCLIENTMETRICS, res As Single, strPuffer As String, i As Integer
ncm.cbSize = 340
res = SystemParametersInfo(SPI_GETNONCLIENTMETRICS, ncm.cbSize, ncm, 0)

If res = 0 Then LastError: Exit Sub

'Debug.Print "MenuFont.Height " & CInt(-0.75 * ncm.lfMenuFont.lfHeight)
'Debug.Print "MenuFont.Weight " & ncm.lfMenuFont.lfWeight '400 = Normal, 700 = Bold
'Debug.Print "MenuFont.Italic " & ncm.lfMenuFont.lfItalic '0 = False, 1 = True
'strPuffer = StrConv(ncm.lfMenuFont.lfFaceName(), vbUnicode)
'Debug.Print "MenuFont " & strPuffer
'Debug.Print "CaptionFont.Height " & CInt(-0.75 * ncm.lfCaptionFont.lfHeight)
'Debug.Print "CaptionFont.Weight " & ncm.lfCaptionFont.lfWeight
'Debug.Print "CaptionFont.Italic " & ncm.lfCaptionFont.lfItalic
'strPuffer = StrConv(ncm.lfCaptionFont.lfFaceName(), vbUnicode)
'Debug.Print "CaptionFont " & strPuffer

Dim lngTitle As Long
Dim Spacelen As Long
Dim theSpaces As Long
'get the font of title
Dim tmpFontName As String
tmpFontName = Me.FontName
strPuffer = StrConv(ncm.lfCaptionFont.lfFaceName(), vbUnicode)
strPuffer = Replace(strPuffer, Chr(0), "")
Me.Font.Name = strPuffer
lngTitle = Me.TextWidth("Hello")

theSpaces = (Me.Width - lngTitle) / 2
Spacelen = Me.TextWidth(" ")
If Spacelen = 0 Then Spacelen = 1
theSpaces = theSpaces / Spacelen
Me.Caption = Space(theSpaces) & "Hello"
'reset fontName
Me.Font.Name = tmpFontName
End Sub

[M.T.P]

از شما دوست عزیز بسیارسپاسگزارم. :تشویق:
اما هر دوتا کد یه جورایی به اول caption فرم Space اضافه میکنن و کلا منطقی به نظر نمیرسه :ناراحت: چون Alt + tab که میزنم عنوان برنامم میشه این (.....)
راه دیگه ای ، API ، ... ؟؟؟؟؟:گیج: :متفکر: