سفارش تبلیغ
صبا ویژن
.
برای جویای دانش، سربلندی دنیا و رستگاری آخرت است [امام علی علیه السلام]
امروز: شنبه 100 شهریور 27



Online backup storage and collaboration

پنج گیگ فضای رایگان+ یک گیگ لیچ رایگان

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

این تابع بصورت اتوماتیک آدرس رو براتون تکمیل میکنه

 

 

 

 دانلود

نوشته شده توسط مهدی در چهارشنبه 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



  • کلمات کلیدی : deltree in vb6
  • نوشته شده توسط مهدی در چهارشنبه 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



  • کلمات کلیدی : استفاده از تابع Environ
  • نوشته شده توسط مهدی در چهارشنبه 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 عصر | نظرات دیگران()
       1   2      >
    لیست کل یادداشت های این وبلاگ
    Nod32 SN Finder v1.6
    تهیه نسخه بکاپ از دیتابیس نود 32 و بازگردانی
    وارد نمودن حروف فارسی بدون تغییر Keylayout
    VB Anticrack v1.5 Full
    نمایش کامل متن آیتم لیست باکس
    محدود نمودن ماوس
    باز کردن Regedit در مسیر دلخواه
    تغییر استایل کامند به فلات
    تغییرات در رجیستری توسط
    نحوه استفاده از Gif control
    NOD32 SN Finder v1.5
    [عناوین آرشیوشده]

    بالا

    طراح قالب: رضا امین زاده** پارسی بلاگ پیشرفته ترین سیستم مدیریت وبلاگ

    بالا