اگه شما نیاز داشته باشید که کاربر آدرس یک شاخه یا فایل رو داخل یک تکست باکس تایپ کنه، این تابع به کمکتون میاد
این تابع بصورت اتوماتیک آدرس رو براتون تکمیل میکنه
دانلود 
نوشته شده توسط مهدی در چهارشنبه 88/9/25 و ساعت 4:26 عصر | نظرات دیگران()آموزش ویژوال بیسیک
اگه شما نیاز داشته باشید که کاربر آدرس یک شاخه یا فایل رو داخل یک تکست باکس تایپ کنه، این تابع به کمکتون میاد
این تابع بصورت اتوماتیک آدرس رو براتون تکمیل میکنه
دانلود نوشته شده توسط مهدی در چهارشنبه 88/9/25 و ساعت 4:26 عصر | نظرات دیگران()این برنامه از تصاویر درون یک پوشه خاص لیست اچ تی ام ال درست میکنه
فقط باید آدرس مسیر حاوی عکسها و فرمت اونهارو به تابع زیر ارسال کنید:
Public Sub convert(path As String, pattern As String)
On Error GoTo z
Open path + "\List.html" For Output As 1
Print #1, "<HTML>"
Print #1, "<HEAD>"
Print #1, "<TITLE>" & path & "</TITLE>"
File1.path = path
File1.pattern = pattern
For i = 0 To File1.ListCount
If File1.List(i) = "" Then Exit Sub
s = File1.path + "\" + File1.List(i)
x = "<A href="" & s & """ & "><IMG WIDTH=100 HEIGHT=100 SRC="" & s & ""></a>"
Print #1, x
Next i
Exit Sub
z:
MsgBox Err.Deion
End Sub
دانلود نوشته شده توسط مهدی در چهارشنبه 88/9/25 و ساعت 4:21 عصر | نظرات دیگران()این تابع تاریخ رو به میلادی میگیره و مشخص میکنه اون تاریخ چند شنبه است.
Public Function DayName(strDate As String) As String
Select Case Weekday(strDate)
Case 7:
DayName = "شنبه"
Case 1:
DayName = "یکشنبه"
Case 2:
DayName = "دوشنبه"
Case 3:
DayName = "سه شنبه"
Case 4:
DayName = "چهارشنبه"
Case 5:
DayName = "پنج شنبه"
Case 6:
DayName = "جمعه"
End Select
End Function
دانلود نوشته شده توسط مهدی در چهارشنبه 88/9/25 و ساعت 4:18 عصر | نظرات دیگران()با سلام
به درخواست دوست گلم آقا کامبیز یه نمونه برنامه براتون میذارم که لیست کلیه پروسسهای در حال اجرا رو نشون میده
که کاربر می تونه هر کدوم از اونها رو انتخاب کنه و اون پروسس رو ببنده
امیدوارم خوشتون بیاد
نظر فراموش نشه
دانلود نوشته شده توسط مهدی در چهارشنبه 88/9/4 و ساعت 4:0 صبح | نظرات دیگران()
یه نرم افزار تهیه کردم به اسم Flash SafeRemove ، همونطور که از اسمش پیداست کارش مدیریت فلش مموری و رم ریدر هست.
اونهایی که همزمان چندین فلش رو به سیستم وصل می کنند ممکنه هنگامی که بخوان یکی از فلشها رو از سیستم جدا کنند نتونند اون فلش رو از داخل منوی Safely Remove تشخیص بدن که این نرم افزار این مشکل رو حل میکنه.
نوشته شده توسط مهدی در چهارشنبه 88/8/27 و ساعت 2:3 عصر | نظرات دیگران()این تابع کارش حذف فولدر با تمام محتویاتش هست که در واقع کار دستور deltree رو انجام میده:
Function DelTree(ByVal strDir As String) As Long
Dim x As Long
Dim intAttr As Integer
Dim strAllDirs As String
Dim strFile As String
DelTree = -1
On Error Resume Next
strDir = Trim$(strDir)
If Len(strDir) = 0 Then Exit Function
If Right$(strDir, 1) = "\" Then strDir = Left$(strDir, Len(strDir) - 1)
If InStr(strDir, "\") = 0 Then Exit Function
intAttr = GetAttr(strDir)
If (intAttr And vbDirectory) = 0 Then Exit Function
strFile = Dir$(strDir & "\*.*", vbSystem Or vbDirectory Or vbHidden)
Do While Len(strFile)
If strFile <> "." And strFile <> ".." Then
intAttr = GetAttr(strDir & "\" & strFile)
If (intAttr And vbDirectory) Then
strAllDirs = strAllDirs & strFile & Chr$(0)
Else
If intAttr <> vbNormal Then
SetAttr strDir & "\" & strFile, vbNormal
If Err Then DelTree = Err: Exit Function
End If
Kill strDir & "\" & strFile
If Err Then DelTree = Err: Exit Function
End If
End If
strFile = Dir$
Loop
Do While Len(strAllDirs)
x = InStr(strAllDirs, Chr$(0))
strFile = Left$(strAllDirs, x - 1)
strAllDirs = Mid$(strAllDirs, x + 1)
x = DelTree(strDir & "\" & strFile)
If x Then DelTree = x: Exit Function
Loop
RmDir strDir
If Err Then
DelTree = Err
Else
DelTree = 0
End If
End Function
نوشته شده توسط مهدی در چهارشنبه 88/8/27 و ساعت 1:47 عصر | نظرات دیگران()یه تابع براتون میذارم که بوسیله اون می تونید به راحتی بر روی دسکتاپ از هر برنامه ای میانبر بسازید:
Public Sub CreateShortCut_Desktop(Target As String, LinkName As String, Deion As String, Optional Hotkey As String = "", Optional Argument As String = "")
Dim WshShell, oShellLink
Set WshShell = Create("W.Shell")
strDesktop = WshShell.SpecialFolders("Desktop")
a1 = InStrRev(Target, "\")
a2 = Mid(Target, 1, Val(a1) - 1)
Set oShellLink = WshShell.CreateShortcut(strDesktop & "\" & LinkName & ".lnk")
oShellLink.TargetPath = Target
oShellLink.WindowStyle = 1
oShellLink.Hotkey = Hotkey
oShellLink.Deion = Deion
oShellLink.Arguments = Argument
oShellLink.WorkingDirectory = a2
oShellLink.Save
End Sub
نوشته شده توسط مهدی در چهارشنبه 88/8/27 و ساعت 1:46 عصر | نظرات دیگران()با استفاده از تابع Environ می تونید به راحتی به یک سری از مشخصات سیستم دست پیدا کنید که برای نمونه چندتا از اونها رو براتون ذکر می کنم:
Environ ("TEMP")
Environ ("TMP")
Environ ("windir")
Environ ("OS")
Environ ("PROCESSOR_IDENTIFIER")
خط اول آدرس شاخه temp رو برمی گردونه، خط دوم ادرس شاخه tmp ، خط سوم آدرس شاخه ویندوز
خط چهارم نوع ویندوز، خط پنجم مدل CPU
نوشته شده توسط مهدی در چهارشنبه 88/8/27 و ساعت 1:43 عصر | نظرات دیگران()برای اینکه برناممون به دفعات مشخصی اجرا بشه و بعد از اون از کار بیفته روشهای زیادی هست که معمولا بهترین روش استفاده از برنامه های AntiCrack و یا Packer ها می باشد (من شخصا از expressor استفاده میکنم)
ولی با استفاده از خود وی بی معمولا شما اطلاعات اجرای برنامه رو داخل یک فایل و یا درون رجیستری ذخیره می کنید و با هر بار اجرای برنامه اون رو چک می کنید. یکی از ساده ترین روشها استفاده از SaveSetting وی بی می باشد. نمونه برنامه ای براتون میذارم که فقط 3 بار اجرا میشه و بعد از اون پیغام خطا میده.
Private Sub Form_Load()
res = GetSetting("MyApp", "Setting", "RunCount", "1")
If Val(res) > 3 Then
MsgBox "The Programe has expired.", vbCritical
End
Else
SaveSetting "MyApp", "Setting", "RunCount", Str(Val(res) + 1)
End If
End Sub
نوشته شده توسط مهدی در چهارشنبه 88/8/27 و ساعت 1:38 عصر | نظرات دیگران()برای اینکه بتونید بفهمید آفیس روی سیستم نصب شده یا نه؟
یک پروژه جدید باز کنید، یک command و چهارتا label به فرمتون اضافه کنید. و کد زیر را داخل قسمت کدنویسی فرمتون اضافه کنید:
Option Explicit
Private Declare Function RegOpenKey Lib _
"advapi32" Alias "RegOpenKeyA" (ByVal hKey _
As Long, ByVal lpSubKey As String, _
phkResult As Long) As Long
Private Declare Function RegQueryValueEx _
Lib "advapi32" Alias "RegQueryValueExA" _
(ByVal hKey As Long, ByVal lpValueName As _
String, lpReserved As Long, lptype As _
Long, lpData As Any, lpcbData As Long) _
As Long
Private Declare Function RegCloseKey& Lib _
"advapi32" (ByVal hKey&)
Private Const REG_SZ = 1
Private Const REG_EXPAND_SZ = 2
Private Const ERROR_SUCCESS = 0
Private Const HKEY_CLASSES_ROOT = &H80000000
Public Function GetRegString(hKey As Long, _
strSubKey As String, strValueName As _
String) As String
Dim strSetting As String
Dim lngDataLen As Long
Dim lngRes As Long
If RegOpenKey(hKey, strSubKey, _
lngRes) = ERROR_SUCCESS Then
strSetting = Space(255)
lngDataLen = Len(strSetting)
If RegQueryValueEx(lngRes, _
strValueName, ByVal 0, _
REG_EXPAND_SZ, ByVal strSetting, _
lngDataLen) = ERROR_SUCCESS Then
If lngDataLen > 1 Then
GetRegString = Left(strSetting, lngDataLen - 1)
End If
End If
If RegCloseKey(lngRes) <> ERROR_SUCCESS Then
MsgBox "RegCloseKey Failed: " & _
strSubKey, vbCritical
End If
End If
End Function
Function FileExists(sFileName$) As Boolean
On Error Resume Next
FileExists = IIf(Dir(Trim(sFileName)) <> "", _
True, False)
End Function
Public Function IsAppPresent(strSubKey$, _
strValueName$) As Boolean
IsAppPresent = CBool(Len(GetRegString(HKEY_CLASSES_ROOT, _
strSubKey, strValueName)))
End Function
Private Sub Command1_Click()
Label1.Caption = "Access " & _
IsAppPresent("Access.Database\CurVer", "")
Label2.Caption = "Excel " & _
IsAppPresent("Excel.Sheet\CurVer", "")
Label3.Caption = "PowerPoint " & _
IsAppPresent("PowerPoint.Slide\CurVer", "")
Label4.Caption = "Word " & _
IsAppPresent("Word.Document\CurVer", "")
End Sub
نوشته شده توسط مهدی در چهارشنبه 88/8/27 و ساعت 1:33 عصر | نظرات دیگران()
|
|
طراح قالب: رضا امین زاده** پارسی بلاگ پیشرفته ترین سیستم مدیریت وبلاگ |
|
