1 ضمیمه
اضافه کردن دکمه Build به تولبار وی بی
بله من عاشق برنامه نویسیم
نكته ويژوال :
توی اين آموزش می خوام بهتون یاد بدم که چه طور مثل ویژال استادیو(نه ورژن 6)دکمه کامپایل(Build) رو اضافه کنید
با یه کلیک می تونید برنامه رو کامپایل کنید
نفر بعدي Setroyd خواهد بود
نقل قول: نفر بعدي كيه ؟ --------- ( ! يك تاپيك جالب و متفاوت ! )
سلام
احتمالا كدش كمي خاص هست
نكته ويژوالي :
همه برنامه هاي باز رو ببنديد، تو يك فرم يك دكمه با عنوان End بزاريد و كد زير رو تو فرم قرار بنويسيد و پروژه رو ذخيره كنيد
بعد براي تست :
1 - برنامه رو اجرا كنيد و دكمه End رو فشار بدين
2 - برنامه رو اجرا كنيد و ضربدر فرم رو بزنيد
3 - برنامه رو اجرا كنيد و با خيال راحت دكمه پاور كيس رو بزنيد
با اين روش راحت ميتونيد بفهميد كه بستن برنامه توسط دكمه ضربدر فرم انجام شده يا با كد خودتون يا اينكه سيستم دستور بسته شدن رو به برنامه داده
Private Sub Command1_Click()
Unload Me
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
MsgBox UnloadMode
If UnloadMode <> 0 And UnloadMode <> 1 Then Cancel = True: MsgBox UnloadMode
End Sub
نفر بعدي شايد همه حالتهاش رو نديده بود
نقل قول: نفر بعدي كيه ؟ --------- ( ! يك تاپيك جالب و متفاوت ! )
من از پشت همین تریبون اعلام میکنم:متعجب: نیستم الان
نکته ویژوالی :
من یه روش خودم کشف کردم نمیدونم بقیه بلدن یا نه
اگه تکراریه به بزرگیتون ببخشین:لبخند:
من دیروز داشتم چند تا کد رو کپی میکردم با ctr+c دستم خورد به shift یعنی شد ctr + shift+ c بعد برای هر خطی که انتخاب کردم ' اومد
وقتی میخواین یه متن بزرگ رو ' بزنین بدرد میخوره
نفر بعدی اندکی ویژوال بیسیک بلد است...
نقل قول: نفر بعدي كيه ؟ --------- ( ! يك تاپيك جالب و متفاوت ! )
:|
|:
نکته ویژوالی :
این کد شاید به دردتون بخوره برای باز کردن آدرس فولدر از کد زیر می تونید استفاده کنید:
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Private Const SW_SHOWNORMAL As Long = 1
Private Sub Command1_Click()
ShellExecute Me.hwnd, "Open", "C:\TEST\", vbNullString, vbNullString, SW_SHOWNORMAL
End Sub
نفر بعد برای زدن تو ذوق من به دنیا اومده.
نقل قول: نفر بعدي كيه ؟ --------- ( ! يك تاپيك جالب و متفاوت ! )
نکته ویژوالی :
از این کد میتونید برای رجیستر کردن فایل هاتون تو ویندوز استفاده کنید به صورت تمام کد و بدون استفاده از regsvr32 یعنی تقریبا کار regsvr32 رو براتون انجام میده
Option Explicit
Private Const CREATE_SUSPENDED = &H4
Private Const INFINITE = &HFFFFFFFF ' Infinite timeout
Private Const STATUS_WAIT_0 = &H0
Private Const STATUS_ABANDONED_WAIT_0 = &H80
Private Const STATUS_TIMEOUT = &H102
Private Const WAIT_FAILED = &HFFFFFFFF
Private Const WAIT_OBJECT_0 = ((STATUS_WAIT_0) + 0)
Private Const WAIT_ABANDONED = ((STATUS_ABANDONED_WAIT_0) + 0)
Private Const WAIT_TIMEOUT = STATUS_TIMEOUT
Private Const STATUS_PENDING = &H103
Private Const STILL_ACTIVE = STATUS_PENDING
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" _
(ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" _
(ByVal hLibModule As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" _
(ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function CreateThread Lib "kernel32" _
(lpThreadAttributes As Any, ByVal dwStackSize As Long, _
lpStartAddress As Long, lpParameter As Any, _
ByVal dwCreationFlags As Long, lpThreadID As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" _
(ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Declare Sub ExitThread Lib "kernel32" (ByVal dwExitCode As Long)
Private Declare Function ResumeThread Lib "kernel32" _
(ByVal hThread As Long) As Long
Private Declare Function GetExitCodeThread Lib "kernel32" _
(ByVal hThread As Long, lpExitCode As Long) As Long
Public Function fVBRegServer(ByVal strFilePath As String, _
Optional ByVal blnRegister = True) As Boolean
Dim lngModuleHandle As Long ' module handle
Dim lngFunctionAdr As Long ' reg/unreg function address
Dim lngThreadID As Long ' dummy var that get's filled
Dim lngThreadHandle As Long ' thread handle
Dim lngExitCode As Long ' thread's exit code if it doesn't finish
Dim blnSuccess As Boolean ' if things worked
'
' Load the file into memory.
'
lngModuleHandle = LoadLibrary(strFilePath)
'
' Get the registration function's address.
'
If blnRegister Then
lngFunctionAdr = GetProcAddress(lngModuleHandle, "DllRegisterServer")
Else
lngFunctionAdr = GetProcAddress(lngModuleHandle, "DllUnregisterServer")
End If
If lngFunctionAdr <> 0 Then
'
' Create an alive thread and execute the function.
'
lngThreadHandle = CreateThread(ByVal 0, 0, ByVal lngFunctionAdr, ByVal 0, 0, lngThreadID)
'
' If we got the thread handle...
'
If lngThreadHandle Then
'
' Wait for the thread to finish.
'
blnSuccess = (WaitForSingleObject(lngThreadHandle, 10000) = WAIT_OBJECT_0)
'
' If it didn't finish...
'
If Not blnSuccess Then
'
' Something happened. Close the thread.
'
Call GetExitCodeThread(lngThreadHandle, lngExitCode)
Call ExitThread(lngExitCode)
End If
'
' Close the thread.
'
Call CloseHandle(lngThreadHandle)
End If
End If
'
' Free the file if we loaded it.
'
If lngModuleHandle Then Call FreeLibrary(lngModuleHandle)
fVBRegServer = blnSuccess
End Function
Public Function IsDLLActiveX(ByVal strDLLPath As String, Optional ByVal RaiseError As Boolean) As Boolean
Dim lngHMod As Long
Dim lngLastDllError As Long
lngHMod = LoadLibrary(strDLLPath)
If lngHMod = 0 Then
If RaiseError Then
lngLastDllError = Err.LastDllError
Err.Raise 10000 + lngLastDllError, "IsDLLActiveX", "LoadLibrary-Error: " & lngLastDllError
End If
End If
IsDLLActiveX = Abs(CBool(GetProcAddress(lngHMod, "DllRegisterServer")))
Call FreeLibrary(lngHMod)
End Function
فانکشن اول رجیستر میکنه و فانکشن دوم هم معلوم میکنه که آیا فایل ما دی ال ال قابل رجیستر هست یا نه
نفر بعدی ی کدی بهتر از مال من میاره
نقل قول: نفر بعدي كيه ؟ --------- ( ! يك تاپيك جالب و متفاوت ! )
نفر بعد باز خودمم :))
نکته ویژوالی :
برای انتخاب فولدر از کد زیر استفاده کنید توجه داشته باشید که فقط انتخاب فولدر نه فایل :
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260
Private Declare Function SHBrowseForFolder Lib "shell32" _
(lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" _
(ByVal pidList As Long, _
ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" _
(ByVal lpString1 As String, ByVal _
lpString2 As String) As Long
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Sub Command1_Click()
'Opens a Treeview control that displays the directories in a computer
Dim lpIDList As Long
Dim sBuffer As String
Dim szTitle As String
Dim tBrowseInfo As BrowseInfo
szTitle = "This is the title"
With tBrowseInfo
.hWndOwner = Me.hWnd
.lpszTitle = lstrcat(szTitle, "")
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
End With
lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
Text1.Text = sBuffer
End If
end sub
نفر بعد رو کن ببینم چی داری؟؟
نقل قول: نفر بعدي كيه ؟ --------- ( ! يك تاپيك جالب و متفاوت ! )
سلام
اولین اولین پست این تاپیک در سال 1394 رو میزارم
نکته ویژوالی :
یک کد گذاشتم برای غیر فعال و فعال کردن Clipboard
Open غیر فعال و Close فعالش میکنه، اگر غیر فعال کنید دیگه هیچ طوری نمیتونید چیزی در Clipboard ذخیره کنید، حتی کلیدهای Ctrl+C, Ctrl+X و ... هم کار نمیکنه
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Sub Form_Load()
'Disable Clipboard
OpenClipboard Me.hwnd
'Enable Clipboard
CloseClipboard
End Sub
نفر بعدی دومین پست رو یک کد جالب بزار
نقل قول: نفر بعدي كيه ؟ --------- ( ! يك تاپيك جالب و متفاوت ! )
اره احتمالا همین طوره ...
بعد از سال ها سر زدم به این انجمن و خاطرات قشنگش .... آخرین پست من اینجا مربوط به بهمن سال 91 هست
چقدر زود میگذره
نکته ویژوالی :
با کد زیر اطلاعات داخل تمام تکست باکس ها رو در لود برنامه حذف کنین
Dim Contrl As Control
For Each Contrl In Form1.Controls
If (TypeOf Contrl Is TextBox) Then Contrl.Text = ""
Next Contrl
نفر بعد تلاششو فقط برای زنده نگه داشتن تاپیک بکنه .... حتی اگه نکته عجیب غریبی نداره
نقل قول: نفر بعدي كيه ؟ --------- ( ! يك تاپيك جالب و متفاوت ! )
سلام
ان شاا... همین پست تاپیکو زنده نگهداره:لبخند:
نکته ویژوالی:
برای ایجاد کردن یک کلاس لزوما نیاز به تعریف یک متغیر جداگانه نیست میتوان آنرا بصورت دیگری هم اعلان کرد، در این شیوه فرض را بر این گذاشته ایم که از With برای دسترسی سریعتر به اعضای کلاس استفاده کرده ایم، در اینجا برخلاف باور بسیاری از کاربران عزیز که حتما بایستی برای استفاده از کلاس در With آنرا در یک متغیر جداگانه ایجاد کرد، میتوانیم مستقیما کلاس مورد نظر را در دستور With ایجاد کنیم، یعنی نوشتن دستورات زیر به هر دو صورت صحیح است:
Private Sub Command1_Click()
Dim CSmplItems As New Collection
With CSmplItems
.Add "ItemA"
.Add "ItemB"
For i = 1 To .Count
MsgBox "Cur Item: " & .Item(i)
Next 'i
End With
End Sub
یا
Private Sub Command1_Click()
With New Collection
.Add "ItemA"
.Add "ItemB"
For i = 1 To .Count
MsgBox "Cur Item: " & .Item(i)
Next 'i
End With
End Sub
البته دوستان توجه داشته باشند که این شیوه صرفا برای ایجاد و دسترسی سریع به اعضای کلاس است و محدودیت هایی در ارجاع و ... دارد.
نفر بعدی سعی کن مطلبی بزنی که دوستان تا یک ساعت از تعجب تاپیکو نتونن ببندن:لبخند:
نقل قول: نفر بعدي كيه ؟ --------- ( ! يك تاپيك جالب و متفاوت ! )
سلام
محسن جان دیگه یک ساعت تعجب که یخورده بعید ولی بهرحال سعی میکنم نکته مفیدی بزارم
نکته ویژوالی :
دستورات انتسابی زیر رو ببینید، با این دستورات محتویات فیلدهای یک Ado به Ado دوم در یک فرم خاص منتقل میشه
frmIRANCustomers.adoIRANCustomerList.Recordset!MNa me = frmIRANCustomers.adoIRANCustomerBackup.Recordset!M Name
frmIRANCustomers.adoIRANCustomerList.Recordset!Fam lily = frmIRANCustomers.adoIRANCustomerBackup.Recordset!F amlily
frmIRANCustomers.adoIRANCustomerList.Recordset!Com ment = frmIRANCustomers.adoIRANCustomerBackup.Recordset!C omment
frmIRANCustomers.adoIRANCustomerList.Recordset!Pho ne = frmIRANCustomers.adoIRANCustomerBackup.Recordset!P hone
frmIRANCustomers.adoIRANCustomerList.Recordset!Ema il = frmIRANCustomers.adoIRANCustomerBackup.Recordset!E mail
frmIRANCustomers.adoIRANCustomerList.Recordset!Add ress = frmIRANCustomers.adoIRANCustomerBackup.Recordset!A ddress
frmIRANCustomers.adoIRANCustomerList.Recordset!Cod e = frmIRANCustomers.adoIRANCustomerBackup.Recordset!C ode
frmIRANCustomers.adoIRANCustomerList.Recordset!Mob ile = frmIRANCustomers.adoIRANCustomerBackup.Recordset!M obile
frmIRANCustomers.adoIRANCustomerList.Recordset!Per sonal = frmIRANCustomers.adoIRANCustomerBackup.Recordset!P ersonal
frmIRANCustomers.adoIRANCustomerList.Recordset!Wei ght = frmIRANCustomers.adoIRANCustomerBackup.Recordset!W eight
frmIRANCustomers.adoIRANCustomerList.Recordset!Old = frmIRANCustomers.adoIRANCustomerBackup.Recordset!O ld
frmIRANCustomers.adoIRANCustomerList.Recordset!Bir thday = frmIRANCustomers.adoIRANCustomerBackup.Recordset!B irthday
frmIRANCustomers.adoIRANCustomerList.Recordset!Fat her = frmIRANCustomers.adoIRANCustomerBackup.Recordset!F ather
frmIRANCustomers.adoIRANCustomerList.Recordset!Mel liCode = frmIRANCustomers.adoIRANCustomerBackup.Recordset!M elliCode
frmIRANCustomers.adoIRANCustomerList.Recordset!Sal ary = frmIRANCustomers.adoIRANCustomerBackup.Recordset!S alary
frmIRANCustomers.adoIRANCustomerList.Recordset!Web site = frmIRANCustomers.adoIRANCustomerBackup.Recordset!W ebsite
خب دستورات طولانی و نسبتا ناخوانایی شده و میشه یه مقدار با With مختصرش کرد به شکل زیر
With frmIRANCustomers.adoIRANCustomerList.Recordset
!MName = frmIRANCustomers.adoIRANCustomerBackup.Recordset!M Name
!Famlily = frmIRANCustomers.adoIRANCustomerBackup.Recordset!F amlily
!Comment = frmIRANCustomers.adoIRANCustomerBackup.Recordset!C omment
!Phone = frmIRANCustomers.adoIRANCustomerBackup.Recordset!P hone
!Email = frmIRANCustomers.adoIRANCustomerBackup.Recordset!E mail
!Address = frmIRANCustomers.adoIRANCustomerBackup.Recordset!A ddress
!Code = frmIRANCustomers.adoIRANCustomerBackup.Recordset!C ode
!Mobile = frmIRANCustomers.adoIRANCustomerBackup.Recordset!M obile
!Personal = frmIRANCustomers.adoIRANCustomerBackup.Recordset!P ersonal
!Weight = frmIRANCustomers.adoIRANCustomerBackup.Recordset!W eight
!Old = frmIRANCustomers.adoIRANCustomerBackup.Recordset!O ld
!Birthday = frmIRANCustomers.adoIRANCustomerBackup.Recordset!B irthday
!Father = frmIRANCustomers.adoIRANCustomerBackup.Recordset!F ather
!MelliCode = frmIRANCustomers.adoIRANCustomerBackup.Recordset!M elliCode
!Salary = frmIRANCustomers.adoIRANCustomerBackup.Recordset!S alary
!Website = frmIRANCustomers.adoIRANCustomerBackup.Recordset!W ebsite
End With
الان بهتر شد ولی هنوزم اون عبارت بزرگ و تکراری وجود داره، ولی خب ویژوال بیسیک 6 رو دست کم نگیرید
Dim rs As Recordset
Set rs = frmIRANCustomers.adoIRANCustomerBackup.Recordset
With frmIRANCustomers.adoIRANCustomerList.Recordset
!MName = rs!MName
!Famlily = rs!Famlily
!Comment = rs!Comment
!Phone = rs!Phone
!Email = rs!Email
!Address = rs!Address
!Code = rs!Code
!Mobile = rs!Mobile
!Personal = rs!Personal
!Weight = rs!Weight
!Old = rs!Old
!Birthday = rs!Birthday
!Father = rs!Father
!MelliCode = rs!MelliCode
!Salary = rs!Salary
!Website = rs!Website
End With
حتما قبول دارید که تا اینجا خیلی بهتر و خواناتر شده و خیلی جاها به همین شکل باید استفاده بشه، ولی به نظرتون بازم میشه مختصر ترش کرد ؟
Dim r1 As Recordset, r2 As Recordset
Set r1 = frmIRANCustomers.adoIRANCustomerList.Recordset: Set r2 = frmIRANCustomers.adoIRANCustomerBackup.Recordset
For i = 0 To r1.Fields.Count - 1
r2.Fields(i) = r1.Fields(i)
Next
در اینجا با یک حلقه همه انتساب ها رو انجام دادیم و دیگه هر چی تعداد فیلدها زیاد بشه کد برنامه همین ثابته و مثل بالایی ها اضافه نمیشه
اما آیا به نظر شما باز هم میشه مختصر کرد ؟!! نظرتون راجع به این چیه
Set frmIRANCustomers.adoIRANCustomerBackup.Recordset = frmIRANCustomers.adoIRANCustomerList.Recordset
این روش رو با روش اول مقایسه کنید !، خیلی کارها رو میشه تو وی بی با این روش ها مختصر کرد و مطمئنا خوانایی برنامه خیلی افزایش پیدا میکنه، این روش آخر برای کلیه آرایه ها قابل انجامه، نمونه زیر رو تست کنید
Dim a1(10), a2(), i%
For i = 0 To 10
a1(i) = i
Next
a2 = a1
نفر بعدی لطفا مطلبی بزار که تو کاربردهای روزمره مفید باشه
نقل قول: نفر بعدي كيه ؟ --------- ( ! يك تاپيك جالب و متفاوت ! )
سلام
اولین پست من در تالارهای ویبی هست :O)
انشاالله مفید باشه
نکته ویژوالی:
همونطور که میدونید دستورات ویبی بصورت تک خطی هستند
اما شما میتونید از آندرلاین ( _ ) برای ایجاد دستورات چند خطی استفاده کنید:
cmd.CommandText = "SELECT * FROM Titles JOIN Publishers " _
& "ON Publishers.PubId = Titles.PubID " _
& "WHERE Publishers.State = 'CA'"
همچنین برای نوشتن چند دستور در یک خط از ( :) استفاده میشه کرد:
text1.Text = "Hello" : text1.BackColor = VbRed
نفر بعدی کارش درسته
نقل قول: نفر بعدي كيه ؟ --------- ( ! يك تاپيك جالب و متفاوت ! )
سلام
کی فکرشو میکرد این تاپیک بعد از 6 سال بالا بیاد !!!!!
نکته ویژوالی:
ای کسانی که ترک vb6 کردین میدونید همین الان در سال 1401 میتونید با vb6 برای کل مجموعه آفیس، فتوشاپ، CorelDraw و ... برنامه و پلاگین بنویسید و کارهاتون رو تو این نرم افزارها اتوماتیک کنید ؟ چون این نرم افزارها همه بر پایه VBA که همون vb6 خودمونه تقریبا کار میکنن
ضمنا زبان ASP هم خیلی تشابه به VB6 داره، همچنین ماکرونویسی در ویندوز
نفر بعدی اصلا این تاپیک رو میبینه ؟ !
نقل قول: نفر بعدي كيه ؟ --------- ( ! يك تاپيك جالب و متفاوت ! )
عجب تاپیک ماندگاری شده
برنامه هایی که حدود 15 سال هست تو بازار برای مشاغل و شرکت ها نوشتم داره براشون کار میده.
فکر کنم لااقل تا زمانی که پلتفرم ویندوز فایل اجرایی exe رو ساپورت کنه
دلم نمیاد از vb6 به محیط دیگه سوییچ کنم
نکته ویژوالی:
با اين كد ميشه عددي تصادفي بين 1 تا 6 پيدا كرد.
MyValue = CInt(Int((6 * Rnd()) + 1))
نفر بعدی احتمالا یه فرازمینی باشه https://barnamenevis.org/images/smilies/yahoo/109.gif
نقل قول: نفر بعدي كيه ؟ --------- ( ! يك تاپيك جالب و متفاوت ! )
سلام و عرض ادب
بله بنده از کره مریخ آمده ام چون بعد از مدتها دوری از vb6 و کار با دات نت، مجددا آمدم سراغش ، انگار غریبه بودیم باهم
نکته ویژوالی:
تابع CreateObject از vb6 اومده و در vb.net هم هنوز در دسترسه و کارهای زیادی میشه باهاش کرد
بعنوان مثال حذف تمامی فایل های موجود در یک فولدر..
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.DeleteFolder "C:\MyFolder\*.*", True
نفر بعدی هرجا هست امیدوارم تنش سلامت باشه