
نوشته شده توسط
mazoolagh
سلام جناب بهرامی گرامی
روز خوش
با اجازه شما نمونه ای که زحمتش رو کشیده بودین دیدم و مثل همیشه تحسین برانگیز بود.
یک پرسش داشتم از حضورتون:
همین روش رو در VB هم تست کردین و جواب گرفتین؟ (دات نت منظورم نیست - همون VB6)
این بخش center شدن caption با resize رو میگم.
عرض سلام و ارادت خدمت استاد مازولاق عزیز !
نمونه ای که در پست 2 ضمیمه شده برای انتقال کپشن به وسط فرم در محیط VB6 تهیه شده
که کدهای نمونه فوق در زیر قرار میدهم که ملاحظه و بررسی بفرمائین
کد های ماژول عمومی:
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 Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const SM_CXSIZE As Long = 30 ' width of a title bar button at 96 DPI
Public Function center_Form_Caption(ByRef formName As Form, ByVal currentTitle)
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 Function
Dim lngTitle As Long
Dim Spacelen As Long
Dim theSpaces As Long
Dim tmpFontName As String
tmpFontName = formName.FontName
strPuffer = StrConv(ncm.lfCaptionFont.lfFaceName(), vbUnicode)
strPuffer = Replace(strPuffer, Chr(0), "")
formName.Font.Name = strPuffer
formName.Font.Size = -ncm.lfCaptionFont.lfHeight / (1440 / Screen.TwipsPerPixelY) * 72
lngTitle = formName.TextWidth(currentTitle)
' theSpaces = (formName.Width - lngTitle) / 2
' note: rgrect(2) below is the Min button. If there is no Min button or no buttons at all,
' change as needed. See this link for what items are in the array of rects
' https://docs.microsoft.com/en-us/windows/desktop/api/winuser/ns-winuser-tagtitlebarinfoex
theSpaces = (formName.ScaleWidth - GetSystemMetrics(SM_CXSIZE) * 3.05 * 15 - lngTitle) / 2
If theSpaces < 1 Then
formName.Caption = currentTitle
Else
Spacelen = formName.TextWidth(" ")
If Spacelen = 0 Then Spacelen = 1
theSpaces = theSpaces / Spacelen
formName.Caption = Right$(Space$(theSpaces) & currentTitle, 255)
End If
' Debug.Print formName.Caption
formName.Font.Name = tmpFontName
End Function
کد مربوطه به فراخوانی تابع انتقال کپشن به وسط فرم:
center_Form_Caption Me, LTrim$(Me.Caption)
کدهائی که بنده جایگزین کدهای فوق برای فرم اکسس کردم شامل موارد زیر میباشه :
دو تابع عمومی در ماژول عمومی :
'Public pubSzrFont As String 'font name
'Public pubSzrSize As Integer 'font size
'Public pubSzrBold As Boolean 'font bold
Public pubSzrText As String 'control text
Public pubSzrWidth As Long 'text width
Function fctSzr(strFont As String, intSize As Integer, strText As String, Optional boBold As Boolean = False) As Long
'pubSzrFont = strFont
'pubSzrSize = intSize
pubSzrText = Replace(strText, " ", "-")
'pubSzrBold = boBold
DoCmd.OpenReport "rptSzr", acViewPreview, , , acHidden
DoCmd.Close acReport, "rptSzr"
fctSzr = pubSzrWidth
End Function
Public Sub CenterCaptionForm(frm As Form, strFont As String, intSize As Integer, strText As String, Optional boBold As Boolean = False)
Dim lngTitle As Long
Dim Spacelen As Long
Dim theSpaces As Long
Dim lngWidth As Long
lngWidth = fctSzr(strFont, intSize, strText, True)
lngTitle = lngWidth
theSpaces = (frm.WindowWidth - lngTitle)
Spacelen = fctSzr("tahoma", 9, " ", True)
If Spacelen = 0 Then Spacelen = 1
theSpaces = theSpaces / Spacelen
frm.Caption = Space(theSpaces) & frm.Caption
End Sub
کد مورد استفاده در بخش Detail_Format گزارش خالی:
Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)
'Me.FontName = pubSzrFont
'Me.FontSize = pubSzrSize
'Me.FontBold = pubSzrBold
pubSzrWidth = Me.TextWidth(pubSzrText) + 30
End Sub
کد فراخوانی تابع انتقال کپشن به وسط تایتل بار فرم:
Call CenterCaptionForm(Me, "tahoma", 8, Me.Caption, False)
همونطور که در پست های 5 و 6 عرض کردم کدهای جایگزین بنده یک ایراد اساسی داره و اون اینکه در هنگام ریسایز فرم ، کپشن به وسط تایتل بار فرم منتقل نمیشه