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

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

نوشته شده توسط مهدی در سه شنبه 88/3/5 و ساعت 5:17 صبح | نظرات دیگران()

 اینم یه ماژول کامل درباره کار با رجیستری

 توابع این ماژول

SetDWORDValue
GetDWORDValue
SetBinaryValue
GetBinaryValue
SetStringValue
GetStringValue
CreateKey
DeleteKey
DelValue
KeyExists

نوشته شده توسط مهدی در سه شنبه 88/3/5 و ساعت 5:11 صبح | نظرات دیگران()

برای اینکار کدهای زیر رو داخل یک ماژول بذارید

Const MAX_PATH = 260
Const TH32CS_SNAPPROCESS = 2&

Private Type PROCESSENTRY32
    lSize            As Long
    lUsage           As Long
    lProcessId       As Long
    lDefaultHeapId   As Long
    lModuleId        As Long
    lThreads         As Long
    lParentProcessId As Long
    lPriClassBase    As Long
    lFlags           As Long
    sExeFile         As String * MAX_PATH
End Type

Private Declare Sub CloseHandle Lib "kernel32" (ByVal hPass As Long)

Private Declare Function CreateToolhelpSnapshot Lib "kernel32" _
    Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, _
    ByVal lProcessId As Long) As Long
   
Private Declare Function ProcessFirst Lib "kernel32" _
    Alias "Process32First" (ByVal hSnapshot As Long, _
    uProcess As PROCESSENTRY32) As Long
   
Private Declare Function ProcessNext Lib "kernel32" _
    Alias "Process32Next" (ByVal hSnapshot As Long, _
    uProcess As PROCESSENTRY32) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, _
    ByVal blnheritHandle As Long, ByVal dwAppProcessId As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal ApphProcess As Long, _
    ByVal uExitCode As Long) As Long

Public Sub EndProcess(procName As String)
Dim sExeName   As String
Dim sPid       As String
Dim sParentPid As String
Dim lSnapShot  As Long
Dim r          As Long
Dim uProcess   As PROCESSENTRY32

Dim fProc As Long

lSnapShot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
uProcess.lSize = Len(uProcess)
r = ProcessFirst(lSnapShot, uProcess)
 Do While r
    sExeName = Left(uProcess.sExeFile, InStr(1, uProcess.sExeFile, vbNullChar) - 1)
    If LCase(sExeName) = LCase(procName) Then
     fProc = uProcess.lProcessId
     Exit Do
    End If
    r = ProcessNext(lSnapShot, uProcess)
Loop
CloseHandle (lSnapShot)

 Dim mProcID As Long
 mProcID = OpenProcess(1&, -1&, fProc)
 TerminateProcess mProcID, 0&

End Sub

و بصورت زیر تابع رو صدا بزنید

EndProcess (نام فایل اجرایی)

نوشته شده توسط مهدی در سه شنبه 88/3/5 و ساعت 5:8 صبح | نظرات دیگران()

برای اینکار خط زیر رو داخل یک ماژول قرار دهید:

Private Declare Function LoadKeyboardLayout Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal pwszKLID As String, ByVal flags As Long) As Long

سپس از دستور زیر برای تغییر زبان استفاده کنید:

 LoadKeyboardLayout "00000429", 1

429 کد زبان فارسی

409 کد زبان انگلیسی

شما می تونید با لود شدن فرم اصلی زبان رو فارسی کرده و با بسته شدن فرم زبان رو انگلیسی کنید.

نوشته شده توسط مهدی در چهارشنبه 88/2/30 و ساعت 2:22 صبح | نظرات دیگران()

 متن ماژول:

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function LoadBitmap Lib "user32" Alias "LoadBitmapA" (ByVal hInstance As Long, ByVal lpBitmapID As Long) As Long
Private Declare Function Delete Lib "gdi32" (ByVal h As Long) As Long
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

Public Function LoadPicture(sResourceFileName As String, lResourceId As Long) As Picture
Dim hInst As Long
Dim hBmp As Long
Dim Pic As PicBmp
Dim IPic As IPicture
Dim IID_IDispatch As GUID
Dim lRC As Long
hInst = LoadLibrary(sResourceFileName)
If hInst <> 0 Then
hBmp = LoadBitmap(hInst, lResourceId)
If hBmp <> 0 Then
IID_IDispatch.Data1 = &H20400
IID_IDispatch.Data4(0) = &HC0
IID_IDispatch.Data4(7) = &H46
Pic.Size = Len(Pic)
Pic.Type = vbPicTypeBitmap
Pic.hBmp = hBmp
Pic.hPal = 0
lRC = OleCreatePictureIndirect(Pic, _
IID_IDispatch, 1, IPic)
If lRC = 0 Then
Set LoadPicture = IPic
Set IPic = Nothing
Else
Call Delete(hBmp)
End If
End If
Call FreeLibrary(hInst)
hInst = 0
End If
End Function

مثال:

Private Sub Form_Load()
"Try ID 130 in Win98, or 131 in NT
"to see the windows logo...
Set Me.Picture = LoadPicture("shell32.dll", 130)
End Sub 

نوشته شده توسط مهدی در پنج شنبه 88/2/24 و ساعت 10:59 عصر | نظرات دیگران()

کافیه یک عدد لیست باکس به فرم اضافه کنید و این کد را داخل فرم بذارید

Private Sub Form_Load()
For I = 1 To Screen.FontCount
    List1.AddItem Screen.Fonts(I)
Next
End Sub

برای اسفاده از فونتها هم از این کد استفاده کنید:

Private Sub List1_Click()
Text1.Font.Name = List1.List(List1.ListIndex)
End Sub

نوشته شده توسط مهدی در پنج شنبه 88/2/24 و ساعت 10:59 عصر | نظرات دیگران()

تابعی برای تبدیل ثانیه به ، ساعت:دقیقه:ثانیه

Public Function ConvertSeconds(lSeconds As Long) As String

    Dim lTmpMinutes As Long
    Dim lTmpSeconds As Long
    Dim lTmpHours As Long
   
    If lSeconds > 59 Then
        lTmpSeconds = lSeconds Mod 60
        If lSeconds > 3599 Then
            lTmpHours = Fix(lSeconds / 3600)
            lTmpMinutes = lSeconds / 60 - (60 * lTmpHours)
            ConvertSeconds = lTmpHours & ":" & Format _
           (lTmpMinutes, "00") & ":" & Format(lTmpSeconds, "00")
        Else
            lTmpMinutes = Fix(lSeconds / 60)
            ConvertSeconds = lTmpMinutes & ":" & _
            Format(lTmpSeconds, "00")
        End If
    Else
        ConvertSeconds = "0:" & Format(lSeconds, "00")
    End If
End Function

نوشته شده توسط مهدی در پنج شنبه 88/2/24 و ساعت 10:58 عصر | نظرات دیگران()

برای این کار داخل یک ماژول این خط رو اضافه کنید

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
Public Const conSwNormal = 1

اینم مثال:

ShellExecute hwnd, "open", "http://vbcode.parsiblog.com", vbNullString, vbNullString, conSwNormal

نوشته شده توسط مهدی در پنج شنبه 88/2/24 و ساعت 10:56 عصر | نظرات دیگران()

 با این کدها برنامه موقعیت فرم اصلی و همچنین طول و عرض آنرا در هنگام بسته شدن برنامه ذخیره می کند

و در اجرای بعدی، فرم را در همان محل و با همان اندازه نمایش می دهد:

Private Sub Form_Load()
    "load settings from the registry
    Me.WindowState = GetSetting(App.Title, Me.Name, "WindowState", Me.WindowState)
    If Me.WindowState = vbNormal Then
        Me.Width = GetSetting(App.Title, Me.Name, "Width", Me.Width)
        Me.Height = GetSetting(App.Title, Me.Name, "Height", Me.Height)
        Me.Left = GetSetting(App.Title, Me.Name, "Left", Me.Left)
        Me.Top = GetSetting(App.Title, Me.Name, "Top", Me.Top)
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    "Save orm dimensions and state in the registry
    SaveSetting App.Title, Me.Name, "WindowState", Me.WindowState
    If Me.WindowState = vbNormal Then
        SaveSetting App.Title, Me.Name, "Height", Me.Height
        SaveSetting App.Title, Me.Name, "Width", Me.Width
        SaveSetting App.Title, Me.Name, "Left", Me.Left
        SaveSetting App.Title, Me.Name, "Top", Me.Top
    End If
End Sub

نوشته شده توسط مهدی در پنج شنبه 88/2/24 و ساعت 10:56 عصر | نظرات دیگران()

Dim intWidth As Integer
Dim intHeight As Integer

intWidth = Screen.Width \ Screen.TwipsPerPixelX
intHeight = Screen.Height \ Screen.TwipsPerPixelY
MsgBox "Screen Resolution:" + vbCrLf + vbCrLf + Str$(intWidth) + " x" + Str$(intHeight), 64, "Info"

نوشته شده توسط مهدی در پنج شنبه 88/2/24 و ساعت 10:53 عصر | نظرات دیگران()