انتقال کپشن فرم به وسط تایتل بار فرم

[atf1379]

سلام
با چه کدی میتوان برای هر فرمی به نسبت اندازه عرض فرم و تعداد حروف کپشن فرم ، متن کپشن را به وسط عنوان یا وسط تایتل بار فرم انتقال داد؟
با تشکر

[atf1379]

یک فایل پیدا کردم که کپشن فرم رو به وسط عنوان فرم انتقال میده منتها این فایل برای محیط VB6 تهیه شده و بخاطر یک سری خصوصیات که فرم های VB6 دارند و فرم های اکسس فاقد این خصوصیات میباشد موفق نشدم در محیط اکسس از کدهای فوق استفاده کنم . خصوصیاتی مثل () formName.TextWidth و formName.FontName

[eb_1345]

--------------------------------------------

[eb_1345]

نمونه ضمیمه رو بررسی بفرما!

[eb_1345]

نمونه بالا رو الآن دوباره امتحان کردم یک مشکلی داره و اون اینکه در هنگام ریسایز شدن فرم متن کپشن جابجا نمیشه که باید بررسی بشه مشکل از کجاست

[eb_1345]

به دلیل تفاوت های خاصی که در خصوصیات فرم اکسس نسبت به فرم های زبانهای برنامه نویسی وجود داره برای اجرای بعضی کارها در فرم های اکسس باید از راه های غیر متعارف استفاده کرد. موضوع این تاپیک هم از اون مواردی است که برای عملی کردنش باید از راهکاری غیر عادی استفاده کرد . مثلاً در نمونه بالا چون فرم اکسس فاقد خصوصیت (...) formName.TextWidth میباشه و این خاصیت در قسمت گزارش وجود داره بنده در نمونه پست 4 برای بدست آوردن مقدار این خصوصیت از یک گزارش خالی استفاده کردم و در قسمت Detail_Format مقدار متغییر عمومی رو معادل این خصوصیت قرار دادم و بعد گزارش رو بصورت مخفی اجرا و بلافاصله دستور بسته شدن اون رو در کدها قرار داده ام.
منتها با این وجود هم اشکالات دیگه ای در اجری اون وجود داره که باید از طریق دیگه برطرف بشه

[atf1379]

با سلام
ممنون از توضیحاتتون
فقط یک سوال
ممکنه بفرمائید تابع () formName.TextWidth چه کاری انجام میده ؟

[eb_1345]

با سلام
ممنون از توضیحاتتون
فقط یک سوال
ممکنه بفرمائید تابع () formName.TextWidth چه کاری انجام میده ؟

اندازه طول کاراکترهای یک متن رو بدست میاره

[mazoolagh]

نمونه بالا رو الآن دوباره امتحان کردم یک مشکلی داره و اون اینکه در هنگام ریسایز شدن فرم متن کپشن جابجا نمیشه که باید بررسی بشه مشکل از کجاست
سلام جناب بهرامی گرامی
روز خوش

با اجازه شما نمونه ای که زحمتش رو کشیده بودین دیدم و مثل همیشه تحسین برانگیز بود.

یک پرسش داشتم از حضورتون:
همین روش رو در VB هم تست کردین و جواب گرفتین؟ (دات نت منظورم نیست - همون VB6)
این بخش center شدن caption با resize رو میگم.

[eb_1345]

سلام جناب بهرامی گرامی
روز خوش

با اجازه شما نمونه ای که زحمتش رو کشیده بودین دیدم و مثل همیشه تحسین برانگیز بود.

یک پرسش داشتم از حضورتون:
همین روش رو در 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 عرض کردم کدهای جایگزین بنده یک ایراد اساسی داره و اون اینکه در هنگام ریسایز فرم ، کپشن به وسط تایتل بار فرم منتقل نمیشه

[eb_1345]

..........

[mazoolagh]

سلام دوباره خدمت جناب بهرامی گرامی


کدهای نمونه فوق در زیر قرار میدهم که ملاحظه و بررسی بفرمائین
کدهای اصلی که برای فرم های VB6 هست رو دیدم،
البته نمیتونم اون رو تست کنم - ظاهرا که درست هست دیگه،
با این وجود برای این که اونها رو در VBA استفاده کنین مناسب نیست
چون یک سری چیزهایی نیاز داره که اینجا نداریم.


شما بیاین از یک راه دیگه برین:
همون SystemParametersInfo رو برای گرفتن مشخصات فونت دیفالت ویندوز برای کپشن فرمها استفاده کنین.
البته الزاما اکسس از این فونت ممکنه استفاده نکنه - به تم و اینها بستگی داره،
ولی خب بیایم امیدوار باشیم که همینه.

بعد از کتابخونه gdi32 استفاده کنین
که یک فانکشن داره که مشخصات فونت رو میدین (مثل همین LOGFONT بجز اسم فونت که استرینگ ساده اس)
و یک فونت میسازه،
حالا یک فانکشن دیگه داره که با این فونت که ساختین و متنی که بهش میدین اندازه های باکس رندر اون رو حساب میکنه (به پیکسل و واسه screen)
- البته من جزئیات کار رو دیگه نیاوردم - (چون باید برم برتامه های 20 سال پیش رو بگردم یا گوگل/بینگ کنم یا از هوش ساختگی کمک بگیرم که شما نیازی به اینها ندارین)

یک بار هم همین پروسه رو برای متنی که فقط space ساده هست انجام مبدین تا اندازه اون هم داشته باشین.

وقتی اندازه رو داشتین مابقی کار دیگه ساده است:
در فرم یک روتین مینویسین که از روی insidewidth و اندازه باکس که بالا بدست آوردین
اندازه جای خالی رو محاسبه کنه (که البته اینم تقریبی هست چون بستگی به آیکون و کنترل باکس فرم هم داره)
و این اندازه رو نصف و به اندازه space تقسیم
و به اندازه بدست آمده space به سمت چپ trim شده کپشن فعلی بچسبونه
و این رو بعنوان کپشن فعلی بگذاره.

این روتین رو در form resize بگذارین و تمام.

=====
برای ریپورت هم همینه روش
فقط اونجا windowwidth باید باشه.

چه در فرم و چه در ریپورت با ریسایز کردن مقدار width عوض نمیشه
برای همین insidewidth یا windowwidth باید استفاده کنین.
========

بعد همه اینها نهایتا شما یک وسط-چین تقریبی دارین!
و بنظرم کلا چیزی نیست که ارزش وقت گذاشتن داشته باشه - مگر بعنوان یک چالش.

==========
برای بینندگان عبوری تاپیک:
اگر زمانی دیدین خواسته هایی دارین
که اکسس بصورت ذاتی نداره
و پیاده سازی اون نیاز به کارهای پیچیده و عجیب و غریب و غیرمتعارف داره

بدونین که یا انتخاب نادرستی کردین یا خواسته تون غیرمنطقیه!

[eb_1345]

و بنظرم کلا چیزی نیست که ارزش وقت گذاشتن داشته باشه - مگر بعنوان یک چالش.

==========
برای بینندگان عبوری تاپیک:
اگر زمانی دیدین خواسته هایی دارین
که اکسس بصورت ذاتی نداره
و پیاده سازی اون نیاز به کارهای پیچیده و عجیب و غریب و غیرمتعارف داره

بدونین که یا انتخاب نادرستی کردین یا خواسته تون غیرمنطقیه!
با عرض سلام متقابل
ممنون بابت توضیحات مفید و مفصلتون
راستش دیروز اومدم از طریق یک سری API Declares و تابع GetStringWidth برای انجام اینکار اقدام کردم ولی در حالت ریسایز نمودن فرم متوجه شدم انجام اینکار برای فرم های اکسس ظاهراً نتیجه بخش نمی باشه ؛ چون وقتی عرض فرم از یک اندازه خاصی بزرگتر میشه متن کپشن بطور کامل نمایش داده نمیشه .
روش جدید رو در فرم نمونه ضمیمه اعمال کرده ام . در فرم نمونه ضمیمه بعد از اجرای فرم ملاحظه خواهی نمود که متن کپشن تقریبا در وسط قرار گرفته ولی اگر فرم رو از طریق پائین نگه داشتن موس و کشیدن لبه سمت راست آن به سمت بیرون ریسایز نمائین متن کپشن کوتاهتر میشه تا جائیکه متن کاملاً غیر قابل نمایش میشه

[mazoolagh]

راستش دیروز اومدم از طریق یک سری API Declares و تابع GetStringWidth برای انجام اینکار اقدام کردم ولی در حالت ریسایز نمودن فرم متوجه شدم انجام اینکار برای فرم های اکسس ظاهراً نتیجه بخش نمی باشه ؛ چون وقتی عرض فرم از یک اندازه خاصی بزرگتر میشه متن کپشن بطور کامل نمایش داده نمیشه .
روش جدید رو در فرم نمونه ضمیمه اعمال کرده ام . در فرم نمونه ضمیمه بعد از اجرای فرم ملاحظه خواهی نمود که متن کپشن تقریبا در وسط قرار گرفته ولی اگر فرم رو از طریق پائین نگه داشتن موس و کشیدن لبه سمت راست آن به سمت بیرون ریسایز نمائین متن کپشن کوتاهتر میشه تا جائیکه متن کاملاً غیر قابل نمایش میشه

سلام دوباره
خدمت جناب بهرامی گرامی

1- این که وقتی پهنای فرم از یک اندازه ای بیشتر میشه،
کپشن رو ناقص نشون میده بخاطر محدودیت ذاتی اندازه خود کپشن هست : 128 کارآکتر
پس شما چک کنین که اگه اندازه رشته با اون space قبلش از 128 بیشتر شد،
از تعداد space ها همون اندازه کم کنین،
اینجوری دیگه آخر کپشن رو نمیبره.
البته بهتره واسه منفی بودن هم چک و به 0 تبدیلش کنین.

2- یک کاری که میتونین بکنین این هست که بجای space (کاراکتر با کد 20 هگز)
از space های دیگه استفاده کنین که پهنای بیشتری دارن (در نتیجه تعداد کمتری نیازه)
مثلا از em space استفاده کنین (کد هگز 2003) و با سعی و خطا ببینین theSpaces رو به چند باید تقسیم کنین (3 مناسبه).

3- حالا درسته که تقریبی هست محاسبات،
ولی از سیستم بگیرین مشخصات فونت کپشن فرم رو
و بجای
lngTitle = GetStringWidth(strText, "Tahoma", 8)
همون رو بدین به تابع CreateFont (البته شما اینو استفاده نکردین)
فونت های کپشن معمولا segui و trebuchet و ... هست.

4- اون 130 نمیدونم از کجا اومده
theSpaces = (Frm.WindowWidth - lngTitle) / 130
ولی GetTextExtentPoint32 اندازه رو به pixel برمیگردونه
که برای تبدیلش به cm باید به 567 تقسیم بشه

[atf1379]

سلام دوباره
خدمت جناب بهرامی گرامی

1- این که وقتی پهنای فرم از یک اندازه ای بیشتر میشه،
کپشن رو ناقص نشون میده بخاطر محدودیت ذاتی اندازه خود کپشن هست : 128 کارآکتر
پس شما چک کنین که اگه اندازه رشته با اون space قبلش از 128 بیشتر شد،
از تعداد space ها همون اندازه کم کنین،
اینجوری دیگه آخر کپشن رو نمیبره.
البته بهتره واسه منفی بودن هم چک و به 0 تبدیلش کنین.

2- یک کاری که میتونین بکنین این هست که بجای space (کاراکتر با کد 20 هگز)
از space های دیگه استفاده کنین که پهنای بیشتری دارن (در نتیجه تعداد کمتری نیازه)
مثلا از em space استفاده کنین (کد هگز 2003) و با سعی و خطا ببینین theSpaces رو به چند باید تقسیم کنین (3 مناسبه).

3- حالا درسته که تقریبی هست محاسبات،
ولی از سیستم بگیرین مشخصات فونت کپشن فرم رو
و بجای
lngTitle = GetStringWidth(strText, "Tahoma", 8)
همون رو بدین به تابع CreateFont (البته شما اینو استفاده نکردین)
فونت های کپشن معمولا segui و trebuchet و ... هست.

4- اون 130 نمیدونم از کجا اومده
theSpaces = (Frm.WindowWidth - lngTitle) / 130
ولی GetTextExtentPoint32 اندازه رو به pixel برمیگردونه
که برای تبدیلش به cm باید به 567 تقسیم بشه

با سلام و خدا قوت خدمت جناب آقای mazoolagh (https://barnamenevis.org/member.php?9893-mazoolagh) و جناب آقای eb_1345 (https://barnamenevis.org/member.php?424036-eb_1345)

با اجازه جناب آقای بهرامی اگه برای جناب mazoolagh (https://barnamenevis.org/member.php?9893-mazoolagh) امکان داره این مواردی رو که فرمودین در یک فایل نمونه ارائه بفرماین
با تشکر

[eb_1345]

ضمنا در حالتی که خصوصیت Orientation فرم در حالت Right-to-Left باشه انتقال کپشن توسط تابع CenterFormCaption انجام نمیشه
چون در این حالت برعکس حالت Left-to-Right که فضای خالی باید قبل از متن کپشن باشه در حالت Right-to-Left فضای خالی باید بعد از متن کپشن اضافه شود
بخاطر همین باید در تابع این حالت بصورت زیر چک شود :


If Frm.Orientation = 0 Then
StrCaption = Space$(Int(theSpaces)) & strText
Else
StrCaption = strText & Space$(Int(theSpaces))
End If

[eb_1345]

با اجازه جناب آقای بهرامی اگه برای جناب mazoolagh (https://barnamenevis.org/member.php?9893-mazoolagh) امکان داره این مواردی رو که فرمودین در یک فایل نمونه ارائه بفرماین
با تشکر
راستش من هر کاری کردم به نتیجه دلخواه نرسیدم . فرم وقتی از یک حدی عریضتر میشه انتقال متن کپشن به وسط محدودتر میشه .

[eb_1345]

با استایل دهی فرم ها به بعضی از استایل ها که متن کپشن رو به وسط عنوان فرم منتقل می کنه این خواسته برآورده میشه

[mazoolagh]

راستش من هر کاری کردم به نتیجه دلخواه نرسیدم . فرم وقتی از یک حدی عریضتر میشه انتقال متن کپشن به وسط محدودتر میشه .

سلام دوباره
این روش که گفتم رو مطمئنم کار میکنه چون قبلا انجام دادم.
ولی باید سیستم های قدیمی رو بگردم (بابت درست بودن جزئیات)
و احتمالا یک دستی به سر روی اون هم بکشم.
====
البته نفس این دست کارها رو درست نمیدونم (نظر شخصی هست البته)
حالا شاید راجع به این هم یک منبر برم.

[mazoolagh]

با استایل دهی فرم ها به بعضی از استایل ها که متن کپشن رو به وسط عنوان فرم منتقل می کنه این خواسته برآورده میشه
در تایپ پست قبلی وقفه افتاد،
و در همین زمان پست جدید شما اومده بوده بود که ندیدم.

پس با اینحساب داستان تمام شده است و پست 19 رو ندیده بگیرید.

[eb_1345]

در تایپ پست قبلی وقفه افتاد،
و در همین زمان پست جدید شما اومده بوده بود که ندیدم.

پس با اینحساب داستان تمام شده است و پست 19 رو ندیده بگیرید.
سلام جناب استاد مازولاق عزیز !
بعد از ارسال پست 18 یادم افتاد که ظاهراً امکان استایل دهی فرم ها در همه نسخه های بالاتر از آفیس 2010 وجود نداره
بخاطر همین تصاویری که در پست 18 ضمیمه کرده بودم حذف کردم.

[eb_1345]

سلام دوباره
این روش که گفتم رو مطمئنم کار میکنه چون قبلا انجام دادم.
ولی باید سیستم های قدیمی رو بگردم (بابت درست بودن جزئیات)
و احتمالا یک دستی به سر روی اون هم بکشم.
====
البته نفس این دست کارها رو درست نمیدونم (نظر شخصی هست البته)
حالا شاید راجع به این هم یک منبر برم.

من خواهش میکنم اگه فرصت داشتین این موضوع رو بررسی کنین و یک نمونه فایل رو ضمیمه بفرمائین !
شاید بقول خودتون این موضوع اهمیت زیادی نداشته باشه ولی بعنوان یک موضوع چالش برانگیز ارزش بررسی کردن رو داره

[mazoolagh]

من خواهش میکنم اگه فرصت داشتین این موضوع رو بررسی کنین و یک نمونه فایل رو ضمیمه بفرمائین !
شاید بقول خودتون این موضوع اهمیت زیادی نداشته باشه ولی بعنوان یک موضوع چالش برانگیز ارزش بررسی کردن رو داره

متوجه شدم،
چَشم - حتما

... TIME

[mazoolagh]

خب برنامه رو پیدا کردم
و همینجور که میبینین مال 25 سال پیش هست

156432

و روی همون سیستم قدیمی هم اجرا میشه (ویندوز 98 + آفیس 97)

البته روی آفیس 2010 هم هنوز قابل تبدیل و اجرا هست،

فعلا کدها و اسکرین شات و برنامه قدیمی رو پیوست میکنم،
شاید سر فرصت تبدیل شده اش رو هم پیوست - و کدها رو هم برای آفیس های مدرن ویرایش کنم.

[mazoolagh]

همین جور که دیده میشه
وسط چین کردن کپشن با دقت خوبی انجام میشه و قابل قبول هست:
از پهنای کم تا حالت maximize

156434

156433

156435

156436

[mazoolagh]

Structures

Option Compare Database
Option Explicit

Public Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(1 To 32) As Byte
End Type

Public 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

Public Type TextSize
Width As Long
Height As Long
WidthCM As Single
HeightCM As Single
End Type

[mazoolagh]

Declares




Option Compare Database
Option Explicit


Public Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" ( _
ByVal uiAction As Long, _
ByVal uiParam As Long, _
ByRef pvParam As Any, _
ByVal fWinIni As Long _
) As Long


Public Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" ( _
ByVal lpszDriver As String, _
ByVal lpszDevice As String, _
ByVal lpszOutput As String, _
ByVal lpInitData As Long) As Long




Public Declare Function DeleteDC Lib "gdi32" ( _
ByVal hdc As Long) As Long




Public Declare Function SelectObject Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal hObject As Long) As Long


Public Declare Function DeleteObject Lib "gdi32" ( _
ByVal hObject As Long) As Long


Public Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" ( _
ByVal hdc As Long, _
ByVal lpString As String, _
ByVal cbString As Long, _
lpSize As TextSize) As Long


Public Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" ( _
ByVal nHeight As Long, _
ByVal nWidth As Long, _
ByVal nEscapement As Long, _
ByVal nOrientation As Long, _
ByVal fnWeight As Long, _
ByVal fdwItalic As Long, _
ByVal fdwUnderline As Long, _
ByVal fdwStrikeOut As Long, _
ByVal fdwCharSet As Long, _
ByVal fdwOutputPrecision As Long, _
ByVal fdwClipPrecision As Long, _
ByVal fdwQuality As Long, _
ByVal fdwPitchAndFamily As Long, _
ByVal lpszFace As String) As Long

[mazoolagh]

Publics

Option Compare Database
Option Explicit


Public Const SPI_GETNONCLIENTMETRICS As Long = 41
Public Const twips = 566.929133858
Public Const twipsPerPixel = 15


Public Function GetTextSize( _
text As String, _
FontName As String, _
Height As Long, _
Width As Long, _
Weight As Long, _
Orientation As Long, _
Italic As Byte, _
Underline As Byte, _
StrikeOut As Byte, _
CharSet As Byte) As TextSize

Dim hdc As Long
Dim hFont As Long
Dim hOldFont As Long
Dim ts As TextSize

hdc = CreateDC("DISPLAY", vbNullString, vbNullString, 0)

hFont = CreateFont( _
lpszFace:=FontName, _
nHeight:=-Height * 20, _
nWidth:=Width, _
nOrientation:=Orientation, _
fnWeight:=Weight, _
fdwItalic:=Italic, _
fdwUnderline:=Underline, _
fdwStrikeOut:=StrikeOut, _
fdwCharSet:=CharSet, _
nEscapement:=0, _
fdwOutputPrecision:=0, _
fdwClipPrecision:=0, _
fdwQuality:=0, _
fdwPitchAndFamily:=0)


hOldFont = SelectObject(hdc, hFont)

GetTextExtentPoint32 hdc, text, Len(text), ts

GetTextSize.Width = ts.Width
GetTextSize.Height = ts.Height
GetTextSize.WidthCM = ts.Width / twips
GetTextSize.HeightCM = ts.Height / twips

SelectObject hdc, hOldFont
DeleteObject hFont
DeleteDC hdc
End Function

[mazoolagh]

Form


Option Compare Database
Option Explicit

Private NCM As NONCLIENTMETRICS
Private CaptionSize As TextSize
Private BlankSize As TextSize
Private CaptionText As String
Private CaptionLength As Integer
Const Blank = " "

Private Sub Form_Load()
CaptionText = Me.Caption
CaptionLength = Len(CaptionText)

NCM.cbSize = Len(NCM)
SystemParametersInfo SPI_GETNONCLIENTMETRICS, NCM.cbSize, NCM, 0

Dim CaptionFontName As String
Dim i As Integer

With NCM.lfCaptionFont
For i = LBound(.lfFaceName) To UBound(.lfFaceName)
If .lfFaceName(i) = 0 Then Exit For
CaptionFontName = CaptionFontName & Chr(.lfFaceName(i))
Next i

BlankSize = GetTextSize( _
Blank, _
CaptionFontName, _
.lfHeight, _
.lfWidth, _
.lfWeight, _
.lfOrientation, _
.lfItalic, _
.lfUnderline, _
.lfStrikeOut, _
.lfCharSet)

CaptionSize = GetTextSize( _
CaptionText, _
CaptionFontName, _
.lfHeight, _
.lfWidth, _
.lfWeight, _
.lfOrientation, _
.lfItalic, _
.lfUnderline, _
.lfStrikeOut, _
.lfCharSet)
End With
End Sub

Private Sub CenterCaption()
Dim CaptionButtonWidth As Integer
CaptionButtonWidth = NCM.iCaptionWidth * twipsPerPixel
Dim AvailableWidth As Single
AvailableWidth = Me.WindowWidth - CaptionButtonWidth
If Me.MinMaxButtons Then
AvailableWidth = AvailableWidth - 2 * CaptionButtonWidth
End If
If Me.CloseButton Then
AvailableWidth = AvailableWidth - CaptionButtonWidth
End If
AvailableWidth = AvailableWidth / twips
Dim x As Single
x = (AvailableWidth - CaptionSize.WidthCM) / 2
Dim n As Integer
n = (x / BlankSize.WidthCM) - 1
If n < 0 Then
n = 0
End If
If n + CaptionLength > 120 Then
n = 120 - CaptionLength
End If
Me.Caption = Space$(n) + CaptionText
End Sub

Private Sub Form_Resize()
CenterCaption
End Sub

[mazoolagh]

بیشتر توضیحات و روش کار رو در پست های 12 و 14 آوردم،
کدها هم دقیقا همون کد 25 سال پیش هست
که فقط در فرم اسم چند متغییر رو تغییر دادم که مفهوم تر باشه
و البته فرمت هم شده برای خوانایی.
و برنامه رو هم که همینجا پیوست میکنم.

[atf1379]

البته روی آفیس 2010 هم هنوز قابل تبدیل و اجرا هست،

فعلا کدها و اسکرین شات و برنامه قدیمی رو پیوست میکنم،
شاید سر فرصت تبدیل شده اش رو هم پیوست - و کدها رو هم برای آفیس های مدرن ویرایش کنم.
سلام استاد
ممنون از پیگیری و زحمتی که متحمل شدین
بنده نمونه رو با آفیس 2010 امتحان کردم ولی کپشن وسط چین نشد
ظاهرا بنا به فرمایش جنابعالی کدها برای اجرا بر روی آفیس های بعدی باید تبدیل شوند
تصویر ضمیمه رو ملاحظه بفرمائید.

[mazoolagh]

این فایل پیوست دقیقا همون فایل پیوست پست 30 هست،
فقط به فرمت accdb تبدیل
و function declaration ها اصلاح شده
بنابر این در هر ویندوز و آفیس (2010 و به بالا) کار میکنه.
منظور از کار کردن این هست که بدون مشکل و خطا اجرا میشه (امیدوارم)

[mazoolagh]

سلام
بنده نمونه رو با آفیس 2010 امتحان کردم ولی کپشن وسط چین نشد

سلام و روز خوش

دلایل وسط چین نشدن (احتمالی)
و راه حل (تقریبی) اون رو در پست های قبلی آوردم.

کار بسیار ساده ای هست که انجامش رو به عهده خودتون میگذارم.

راهنمایی:
به کدهایی که در ماجول ها امده دست نزنین.

[atf1379]

این فایل پیوست دقیقا همون فایل پیوست پست 30 هست،
فقط به فرمت accdb تبدیل
و function declaration ها اصلاح شده
بنابر این در هر ویندوز و آفیس (2010 و به بالا) کار میکنه.
منظور از کار کردن این هست که بدون مشکل و خطا اجرا میشه (امیدوارم)

با عرض سلام و خدا قوت
کدها بدون مشکل و خطا اجرا میشه ولی وسط چین نمیشه
امیدوارم دوستان دیگه هم نمونه رو بر روی سیستم خودشان امتحان و نتیجه رو اعلام فرمایند .
شاید آفیس سیستم بنده مشکل داشته باشه که کپشن وسط چین نمیشه

[atf1379]

سلام و روز خوش

====



دلایل وسط چین نشدن (احتمالی)
و راه حل (تقریبی) اون رو در پست های قبلی آوردم.

کار بسیار ساده ای هست که انجامش رو به عهده خودتون میگذارم.

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

[mazoolagh]

بخش فنی و سخت کار همونی هست که در ماجول ها آمده،
مابقی چند خط محاسبه بسیار ساده و در نظر گرفتن پست های قبلی هست.

[atf1379]

با اکسس 2003 هم وسط چین نشد

[atf1379]

در فرم های VB6 این مشکل وجود ندارد .


Me.Caption = Space(190) & Me.Caption


با تعداد 190 کارکتر فضای خالی در یک فرم تقریباً عریض کپشن به وسط فرم منتقل میشه ولی در فرم اکسس با همان اندازه و با این تعداد کاراکتر کلا کپشن نمایش داده نمیشه

[atf1379]

شاید این موضوع اهمیت زیادی نداشته باشه ولی بعنوان یک موضوع چالش برانگیز ارزش بررسی کردن رو داره
ان شاءالله این تاپیک با برطرف شدن چالشی که داره به نتیجه برسه

[mazoolagh]

ان شاءالله این تاپیک با برطرف شدن چالشی که داره به نتیجه برسه

در واقع این تاپیک تموم شده است!
ولی بنظر میرسه اصلا به پست ها دقت نمیکنین،
برای همین دوباره برای بینندگان عبوری میگم:

برنامه پیوست کامل هست
همه چیز در پست 12 و 14 آمده،
برای ویندوزهای بالاتر باید همونها رو پیاده کنین - بخصوص ویندوز 11

============

1- هوش ساختگی کوپایلوت (و چند تای دیگه) رو برای پاسخ کامل و دقیق train کردم (برای کپی/پیست کارها).


2- راه بسیار بهتر (از نظر نتیجه) و ساده تری (از نظر پیچیدگی کد و بی نیاز بودن از محاسبات) هم هست
ولی چون تاپیک در این مسیر نیست از اون میگذرم.

[atf1379]

در واقع این تاپیک تموم شده است!
ولی بنظر میرسه اصلا به پست ها دقت نمیکنین،


پست های 12 و 14 رو چند بار مرور کردم ولی واقعاً بخاطر تخصصی بودن مطالب(حداقل برای بنده) چیزی سردرنیاوردم و اصلاً نتونستم مطالب جنابعالی رو بهم ربط بدهم و در نهایت به نتیجه دلخواه برسم
خلاصه مطالب پست های 12 و 14 :


شما بیاین از یک راه دیگه برین:
همون SystemParametersInfo رو برای گرفتن مشخصات فونت دیفالت ویندوز برای کپشن فرمها استفاده کنین.
بعد از کتابخونه gdi32 استفاده کنین
که یک فانکشن داره که مشخصات فونت رو میدین (مثل همین LOGFONT بجز اسم فونت که استرینگ ساده اس)
و یک فونت میسازه،
حالا یک فانکشن دیگه داره که با این فونت که ساختین و متنی که بهش میدین اندازه های باکس رندر اون رو حساب میکنه (به پیکسل و واسه screen)
یک بار هم همین پروسه رو برای متنی که فقط space ساده هست انجام مبدین تا اندازه اون هم داشته باشین.
وقتی اندازه رو داشتین مابقی کار دیگه ساده است:
در فرم یک روتین مینویسین که از روی insidewidth و اندازه باکس که بالا بدست آوردین
اندازه جای خالی رو محاسبه کنه (که البته اینم تقریبی هست چون بستگی به آیکون و کنترل باکس فرم هم داره)
و این اندازه رو نصف و به اندازه space تقسیم
و به اندازه بدست آمده space به سمت چپ trim شده کپشن فعلی بچسبونه
و این رو بعنوان کپشن فعلی بگذاره.
این روتین رو در form resize بگذارین و تمام.



2- یک کاری که میتونین بکنین این هست که بجای space (کاراکتر با کد 20 هگز)
از space های دیگه استفاده کنین که پهنای بیشتری دارن (در نتیجه تعداد کمتری نیازه)
مثلا از em space استفاده کنین (کد هگز 2003) و با سعی و خطا ببینین theSpaces رو به چند باید تقسیم کنین (3 مناسبه).
3- حالا درسته که تقریبی هست محاسبات،
ولی از سیستم بگیرین مشخصات فونت کپشن فرم رو
و بجای
lngTitle = GetStringWidth(strText, "Tahoma", 8)
همون رو بدین به تابع CreateFont (البته شما اینو استفاده نکردین)
فونت های کپشن معمولا segui و trebuchet و ... هست.

[atf1379]

بنده کلاً بی خیال موضوع این تاپیک شدم . ان شاءالله مطالب تاپیک برای دوستان دیگه مفید فایده واقع بشه