كد هاي مفيد ويژوال (بعضي به همراه سورس)

[skh1300]

سلام مي خوام براتون چند تا سورس بدرد بوخور را بزارم خودم خيلي با اين سورس ها حال كردم
سورس كم و زياد كردن صدا

---

از دوستان مي خوام كمك كنن
عكس گرفتن همراه با ثانيه شمار

---

يك سورس كه مي توانيد سورس هاتون را در اون نگهداري كنيد

---

يك فولدر ويو (folder view) خيلي باحال و كاربردي

---

ساخت فرم درون خود فرم حتما دانلود كنيد

[skh1300]

انتخاب رنگي كه موس روي آن قرار دارد

کد php:

Option Explicit
Private Type POINTAPI
 x As Long
 y As Long
End Type
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long

Private Sub Form_Load()
Timer1.Interval = 100
End Sub
Private Sub Timer1_Timer()
Dim tPOS As POINTAPI
Dim sTmp As String
Dim lColor As Long
Dim lDC As Long
lDC = GetWindowDC(0)
Call GetCursorPos(tPOS)
lColor = GetPixel(lDC, tPOS.x, tPOS.y)
Label1.BackColor = lColor
sTmp = Right$("000000" & Hex(lColor), 6)
Caption = "R:" & Right$(sTmp, 2) & " G:" & Mid$(sTmp, 3, 2) & " B:" & Left$(sTmp, 2)
End Sub 


---

[skh1300]

يك ماژول بسيار كاربردي

کد php:

'****************************************************
'* COMMON01.BAS Version 1.4 Date: 12/01/94 *
'* VB Tips & Tricks *
'* 8430-D Summerdale Road San Diego CA 92126-5415 *
'* Compuserve: 74227,1557 *
'* America On-Line: DPMCS *
'****************************************************
Declare Function WritePrivateProfileString Lib "Kernel" (ByVal AppName As String, ByVal KeyName As String, ByVal NewString As String, ByVal filename As String) As Integer
Declare Function GetPrivateProfilestring Lib "Kernel" (ByVal AppName As String, ByVal KeyName As String, ByVal default As String, ByVal ReturnedString As String, ByVal MAXSIZE As Integer, ByVal filename As String) As Integer
Declare Function GetKeyState Lib "User" (ByVal NVirtKey%) As Integer

Declare Function FindWindow Lib "User" (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Integer
Declare Sub ShowWindow Lib "User" (ByVal hWnd As Integer, ByVal nCmdShow As Integer)
Declare Sub SFocus Lib "User" Alias "SetFocus" (ByVal hWnd As Integer)
Declare Sub SetWindowPos Lib "User" (ByVal hWnd As Integer, ByVal hWndInsertAfter As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal wFlags As Integer)

Global hWnd As Integer

Const SWP_NOMOVE = 2
Const SWP_NOSIZE = 1
Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2

Declare Function GetModuleUsage Lib "Kernel" (ByVal hModule As Integer) As Integer
Declare Function WinExec Lib "Kernel" (ByVal lpCmdLine As String, ByVal nCmdShow As Integer) As Integer

'CTRL3D DECLARE
Declare Function GetModuleHandle Lib "Kernel" (ByVal ModuleName As String) As Integer
Declare Function Ctl3dAutoSubclass Lib "Ctl3D.DLL" (ByVal hInst As Integer) As Integer
Declare Function Ctl3dRegister Lib "Ctl3D.DLL" (ByVal hInst As Integer) As Integer
Declare Function Ctl3dUnregister Lib "Ctl3D.DLL" (ByVal hInst As Integer) As Integer

'*******************************************************
'* Procedure Name: AppRunning *
'*-----------------------------------------------------*
'* Created: 2/8/94 By: MSDN *
'* Modified: By: *
'*=====================================================*
'*Checks to see if the current application is already *
'*running. To use just call the sub. If the application*
'*is already running, it will end the current *
'*application. *
'* *
'*******************************************************
Sub AppRunning()
 Dim sMsg As String
 If App.PrevInstance Then
 sMsg = App.EXEName & " already running! "
 MsgBox sMsg, 4112
 End
 End If
End Sub

'*******************************************************
'* Procedure Name: CenterForm *
'*-----------------------------------------------------*
'* Created: 2/10/94 By: VB Programmers Journal *
'* Modified: 4/24/94 By: David McCarter *
'*=====================================================*
'*This code will center a form in the center of the *
'*screen. To use it, just call the sub and pass it the *
'*form name [Call CenterForm main] *
'* *
'* *
'*******************************************************
Sub CenterForm(frmIN As Form)
 Dim iTop As Integer, iLeft As Integer

 If frmIN.WindowState <> 0 Then Exit Sub
 iTop = (Screen.Height - frmIN.Height) \ 2
 iLeft = (Screen.Width - frmIN.Width) \ 2
 
 'If iTop And iLeft Then
 frmIN.Move iLeft, iTop
 'End If
End Sub

'*******************************************************
'* Procedure Name: CenterMDIChild *
'*-----------------------------------------------------*
'* Created: 2/10/94 By: VB Programmers Journal *
'* Modified: 3/24/94 By: D. McCarter *
'*=====================================================*
'* Centers a child form within a parent MDI form. To *
'* use, call the sub and pass it the parent form name *
'* and the child form name [CenterMDIChild form1 form2]*
'* *
'* *
'*******************************************************
Sub CenterMDIChild(frmParent As Form, frmChild As Form)
 Dim iTop As Integer, iLeft As Integer
 If frmParent.WindowState <> 0 Or frmChild.WindowState <> 0 Then Exit Sub
 iTop = (frmParent.ScaleHeight - frmChild.Height) \ 2
 iLeft = (frmParent.ScaleWidth - frmChild.Width) \ 2

 If iTop And iLeft Then
 frmChild.Move iLeft, iTop
 End If
End Sub

'*******************************************************
'* Procedure Name: CheckUnique *
'*-----------------------------------------------------*
'* Created: 4/18/94 By: Terry Brooking *
'* Modified: By: *
'*=====================================================*
'*Checks for previous instance of application, If found*
'*ensures it's restored from Icon and Focused on! It is*
'*up to main routine to end application if required. *
'* *
'* *
'*******************************************************
Function CheckUnique(F As Form) As Integer
'Check for previous instance of application. If found, ensures
'is restored from Icon and Focused on! It is up to Main routine
'to end application if required.
Dim X As Integer
Dim Title As String

 CheckUnique = True
 If App.PrevInstance Then
 'MsgBox "Prev Instance found!"
 Title = F.Caption
 F.Caption = Title & " - New" 'This is necessary as you may find yourself!
 hWnd = FindWindow(0&, Title)
 F.Caption = Title 'Restore caption
 DoEvents
 If hWnd Then
 'MsgBox "Handle found!"
 ShowWindow hWnd, 1 'Restores from Minimsed if necessary
 DoEvents
 SFocus hWnd 'Sets focus
 DoEvents
 CheckUnique = False
 End If
 End If
End Function

'*******************************************************
'* Procedure Name: CutCopyPaste *
'*-----------------------------------------------------*
'* Created: By: VB Help File *
'* Modified: By: *
'*=====================================================*
'*This procedure puts all the cut,copy paste commands *
'*in one place. To use, just call the sub and pass it *
'*your choice- 0=Cut, 1=Copy, 2=Paste, 3=Delete, *
'*[Call CutCopyPaste 2] *
'* *
'*******************************************************
Sub CutCopyPaste(iChoice As Integer)
 ' ActiveForm refers to the active form in the MDI form.
 If TypeOf Screen.ActiveControl Is TextBox Then
 Select Case iChoice
 Case 0 ' Cut.
 ' Copy selected text to Clipboard.
 Clipboard.SetText Screen.ActiveControl.SelText
 ' Delete selected text.
 Screen.ActiveControl.SelText = ""
 Case 1 ' Copy.
 ' Copy selected text to Clipboard.
 Clipboard.SetText Screen.ActiveControl.SelText
 Case 2 ' Paste.
 ' Put Clipboard text in text box.
 Screen.ActiveControl.SelText = Clipboard.GetText()
 Case 3 ' Delete.
 ' Delete selected text.
 Screen.ActiveControl.SelText = ""
 End Select
 End If
End Sub

'*******************************************************
'* Procedure Name: DOSSHELL *
'*-----------------------------------------------------*
'* Created: 8/13/94 By: David McCarter *
'* Modified: By: *
'*=====================================================*
'*Executes a Shell function and does not return control*
'*to your program until the shell is finished. The *
'*Shell string should contain all info for the shell *
'*including path and file name. WinType should be one *
'*of these values: *
'*Normal Window=1 *
'*Maximized Window=3 *
'*Minimized Window=6 *
'*Hidden Window=0 *
'*******************************************************
Sub DOSShell(ShellString As String, WinType As Integer)
Dim InstanceHandle As Integer, X As Integer
InstanceHandle = Shell(ShellString, WinType)
Do While GetModuleUsage(InstanceHandle) > 0
 X = DoEvents()
Loop
End Sub

'*******************************************************
'* Procedure Name: FileExists *
'*-----------------------------------------------------*
'* Created: 8/29/94 By: David McCarter *
'* Modified: By: *
'*=====================================================*
'*This function will check to make sure that a file *
'*exists.It will return True if the file was found and *
'*False if it was not found. *
'*Example: If Not FileExists("autoexec.bat") Then... *
'*******************************************************
Function FileExists(filename As String) As Integer
Dim i As Integer
On Error Resume Next
i = Len(Dir$(filename))
If Err Or i = 0 Then
 FileExists = False
 Else
 FileExists = True
End If
End Function

'*******************************************************
'* Procedure Name: FixAmper *
'*-----------------------------------------------------*
'* Created: By: Bart Larsen *
'* Modified: By: *
'*=====================================================*
'*This function fixes strings that are to be used by a *
'*Label control so the "&" (Chr(38)) does not *
'*underscore the following character. *
'*[Label1.Caption=FixAmper("bf&ftr.zip")] *
'* *
'*******************************************************
Function FixAmper(Strng As String) As String
Dim sTemp As String, n As Integer
 While InStr(Strng, "&")
 n = InStr(Strng, "&")
 sTemp = sTemp + Left$(Strng, n) + "&"
 Strng = Mid$(Strng, n + 1)
 Wend
 sTemp = sTemp + Strng
 FixAmper = sTemp
End Function

'*******************************************************
'* Procedure Name: GetAppPath *
'*-----------------------------------------------------*
'* Created: 3/24/94 By: David McCarter *
'* Modified: By: *
'*=====================================================*
'*Returns the application path with a trailing \. *
'*To use, call the function [SomeString=GetAppPath()] *
'* *
'* *
'* *
'*******************************************************
Function GetAPPPath() As String
 Dim sTemp As String
 sTemp = App.Path
 If Right$(sTemp, 1) <> "\" Then sTemp = sTemp + "\"
 GetAPPPath = sTemp
End Function

'*******************************************************
'* Procedure Name: CheckUnique *
'*-----------------------------------------------------*
'* Created: 4/18/94 By: KeepOnTop *
'* Modified: By: *
'*=====================================================*
'*Keep form on top. Note that this is switched off if *
'*form is minimised, so place in resize event as well. *
'* *
'* *
'* *
'*******************************************************
Sub KeepOnTop(F As Form)
'Keep form on top. Note that this is switched off if form is
'minimised, so place in resize event as well.
Const wFlags = SWP_NOMOVE Or SWP_NOSIZE

 SetWindowPos F.hWnd, HWND_TOPMOST, 0, 0, 0, 0, wFlags 'Window will stay on top
 'To undo call again with HWND_NOTOPMOST
 DoEvents
End Sub

'*******************************************************
'* Procedure Name: LongDirFix *
'*-----------------------------------------------------*
'* Created: 6/30/94 By: David McCarter *
'* Modified: By: *
'*=====================================================*
'*This function will shorten a directory name to the *
'*length passed to it. *
'*Usage: Label1.Caption=LongDirFix(sDirName, 32) *
'*The second paramater the the max length of the *
'*returned string. *
'*******************************************************
Function LongDirFix(Incomming As String, Max As Integer) As String
Dim i As Integer, LblLen As Integer, StringLen As Integer
Dim TempString As String

TempString = Incomming
LblLen = Max

If Len(TempString) <= LblLen Then
 LongDirFix = TempString
 Exit Function
End If

LblLen = LblLen - 6

For i = Len(TempString) - LblLen To Len(TempString)
 If Mid$(TempString, i, 1) = "\" Then Exit For
 
Next

LongDirFix = Left$(TempString, 3) + "..." + Right$(TempString, Len(TempString) - (i - 1))

End Function

'*******************************************************
'* Procedure Name: MakeDir *
'*-----------------------------------------------------*
'* Created: 8/29/94 By: David McCarter *
'* Modified: By: *
'*=====================================================*
'*This function will create a directory even if the *
'*underlying directories do not exist. *
'*Usage: MakeDir "c:\temp\demo" *
'*This procedue also uses the ValDir to find if the *
'*directory already exists. *
'*******************************************************
Sub MakeDir(sDirName As String)
Dim iMouseState As Integer
Dim iNewLen As Integer
Dim iDirLen As Integer

'Get Mouse State
iMouseState = Screen.MousePointer

'Change Mouse To Hour Glass
Screen.MousePointer = 11

'Set Start Length To Search For [\]
iNewLen = 4

'Add [\] To Directory Name If Not There
If Right$(sDirName, 1) <> "\" Then sDirName = sDirName + "\"

'Create Nested Directory
While Not ValDir(sDirName)
 iDirLen = InStr(iNewLen, sDirName, "\")
 Debug.Print Left$(sDirName, iDirLen)
 If Not ValDir(Left$(sDirName, iDirLen)) Then
 MkDir Left$(sDirName, iDirLen - 1)
 End If
 iNewLen = iDirLen + 1
Wend

'Leave The Mouse The Way You Found It
Screen.MousePointer = iMouseState

End Sub

'*******************************************************
'* Procedure Name: ReadINI *
'*-----------------------------------------------------*
'* Created: By: Daniel Bowen *
'* Modified: 3/24/94 By: David McCarter *
'*=====================================================*
'*Returns a string from an INI file. To use, call the *
'*functions and pass it the AppName, KeyName and INI *
'*File Name, [sReg=ReadINI(App1,Key1,INIFile)]. If you *
'*need the returned value to be a integer then use the *
'*val command. *
'*******************************************************
Function ReadINI(AppName, KeyName, filename As String) As String
Dim sRet As String
sRet = String(255, Chr(0))

ReadINI = Left(sRet, GetPrivateProfilestring(AppName, ByVal KeyName, "", sRet, Len(sRet), filename))

End Function

'*******************************************************
'* Procedure Name: SelectText *
'*-----------------------------------------------------*
'* Created: 2/14/94 By: David McCarter *
'* Modified: By: *
'*=====================================================*
'*Selects all the text in a text box. Call it when the *
'*text box get focus, [SelectText Text1.text] *
'* *
'* *
'* *
'*******************************************************
Sub SelectText(ctrIn As Control)
ctrIn.SelStart = 0
ctrIn.SelLength = Len(ctrIn.Text)
End Sub

'*******************************************************
'* Procedure Name: Turn3DOff *
'*-----------------------------------------------------*
'* Created: 11/12/94 By: David McCarter *
'* Modified: By: *
'*=====================================================*
'* This function turns off the 3D effect for VB *
'* message boxes turn on by the Turn3DOn function. You *
'* MUST makes sure this function is called before the *
'* program ends! *
'* *
'*******************************************************
Sub Turn3DOff()
Dim INST As Integer
Dim RET As Integer

 INST = GetModuleHandle(App.EXEName)
 RET = Ctl3dUnregister(INST)

End Sub

'*******************************************************
'* Procedure Name: Turn3DOn *
'*-----------------------------------------------------*
'* Created: 11/12/94 By: David McCarter *
'* Modified: By: *
'*=====================================================*
'* Use this function to turn on a 3D effect on all *
'* Windows message and dialog boxes your program uses. *
'* You must call the Turn3DOff function before the *
'* program ends or VBT (very bad things) will happen! *
'* *
'*******************************************************
Sub Turn3DOn()
Dim INST As Integer
Dim RET As Integer

 INST = GetModuleHandle(App.EXEName)
 RET = Ctl3dRegister(INST)
 RET = Ctl3dAutoSubclass(INST)

End Sub

'*******************************************************
'* Procedure Name: ValDir *
'*-----------------------------------------------------*
'* Created: 8/29/94 By: David McCarter *
'* Modified: By: *
'*=====================================================*
'*This function is used by MakeDir to validate if a *
'*directory already exists. *
'*******************************************************
Function ValDir(sIncoming As String) As Integer
Dim iCheck As String, iErrResult As Integer

On Local Error GoTo ValDirError

'If Right$(sIncoming, 1) <> "\" Then sIncoming = sIncoming + "\"
iCheck = Dir$(sIncoming)

If iErrResult = 76 Then
 ValDir = False
 Else
 ValDir = True
End If

Exit Function

ValDirError:

Select Case Err
 Case Is = 76
 iErrResult = Err
 Resume Next
 Case Else
End Select

End Function

'*******************************************************
'* Procedure Name: WriteINI *
'*-----------------------------------------------------*
'* Created: 2/10/94 By: David McCarter *
'* Modified: By: *
'*=====================================================*
'*Writes a string to an INI file. To use, call the *
'*function and pass it the AppName, KeyName, the New *
'*String and the INI File Name, *
'*[R=WriteINI(App1,Key1,sReg,INIFile)]. Returns a 1 if *
'*there were no errors and a 0 if there were errors. *
'*******************************************************
Function WriteINI(AppName, KeyName, NewString, filename As String) As Integer
WriteINI = WritePrivateProfileString(AppName, KeyName, NewString, filename)
End Function 


---

پخش avi

کد php:

Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As Any, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Sub Play_AVI(FileName As String)
    Dim lngReturnVal As Long
    lngReturnVal = mciSendString("play " & FileName & " fullscreen ", 0&, 0, 0&)
End Sub 


در فرم
Call Play_AVI("C:\windows\clock.avi")

---

پخش wav و midi

کد php:

' ----------------------------
' Constants & API Declarations
' ----------------------------

Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long

Public Const SND_ALIAS = &H10000     '  name is a WIN.INI [sounds] entry
Public Const SND_ASYNC = &H1         '  play asynchronously
Public Const SND_LOOP = &H8         '  loop the sound until next sndPlaySound
Public Const SND_NOWAIT = &H2000      '  don't wait if the driver is busy
Public Const SND_SYNC = &H0         '  play synchronously (default)


' ---------------
' Function
' ---------------

Public Sub PlaySound(FileName As String)
    Call sndPlaySound(FileName, 1)
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''کدي ديگر براي پخش wav و mdi
Declare Function mciExecute Lib "winmm.dll" (ByVal lpstrcommand As String) As Long


Private Sub Command1_Click()
iresult = mciExecute("play C:\WINDOWS\MEDIA\Notify.wav")
End Sub 


[skh1300]

به راحتي فرم را بزرگ و كوچك كنيد
(چند تا دكمه و چند تا text بزارين )

کد php:

Public Type ctrObj
  Name As String
  Index As Long
  Parrent As String
  Top As Long
  Left As Long
  Height As Long
  Width As Long
  ScaleHeight As Long
  ScaleWidth As Long
End Type

Private FormRecord() As ctrObj
Private ControlRecord() As ctrObj
Private bRunning As Boolean
Private MaxForm As Long
Private MaxControl As Long

Private Function ActualPos(plLeft As Long) As Long
  If plLeft < 0 Then
    ActualPos = plLeft + 75000
  Else
    ActualPos = plLeft
  End If
End Function

Private Function FindForm(pfrmIn As Form) As Long
  Dim i As Long
  
  FindForm = -1
  If MaxForm > 0 Then
    For i = 0 To (MaxForm - 1)
      If FormRecord(i).Name = pfrmIn.Name Then
        FindForm = i
        Exit Function
      End If
    Next i
  End If
End Function


Private Function AddForm(pfrmIn As Form) As Long
  Dim FormControl As Control
  Dim i As Long
  ReDim Preserve FormRecord(MaxForm + 1)

  FormRecord(MaxForm).Name = pfrmIn.Name
  FormRecord(MaxForm).Top = pfrmIn.Top
  FormRecord(MaxForm).Left = pfrmIn.Left
  FormRecord(MaxForm).Height = pfrmIn.Height
  FormRecord(MaxForm).Width = pfrmIn.Width
  FormRecord(MaxForm).ScaleHeight = pfrmIn.ScaleHeight

  FormRecord(MaxForm).ScaleWidth = pfrmIn.ScaleWidth
  AddForm = MaxForm
  MaxForm = MaxForm + 1

  For Each FormControl In pfrmIn
    i = FindControl(FormControl, pfrmIn.Name)
    If i < 0 Then i = AddControl(FormControl, pfrmIn.Name)
  Next FormControl
End Function

Private Function FindControl(inControl As Control, inName As String) As Long
  Dim i As Long
  
  FindControl = -1
  For i = 0 To (MaxControl - 1)
    If ControlRecord(i).Parrent = inName Then
      If ControlRecord(i).Name = inControl.Name Then
        On Error Resume Next
        
        If ControlRecord(i).Index = inControl.Index Then
          FindControl = i
          Exit Function
        End If
        On Error GoTo 0
      
      End If
    End If
  Next i
End Function

Private Function AddControl(inControl As Control, inName As String) As Long
  ReDim Preserve ControlRecord(MaxControl + 1)
  On Error Resume Next
  
  ControlRecord(MaxControl).Name = inControl.Name
  ControlRecord(MaxControl).Index = inControl.Index
  ControlRecord(MaxControl).Parrent = inName

  If TypeOf inControl Is Line Then
    ControlRecord(MaxControl).Top = inControl.Y1
    ControlRecord(MaxControl).Left = ActualPos(inControl.X1)
    ControlRecord(MaxControl).Height = inControl.Y2
    ControlRecord(MaxControl).Width = ActualPos(inControl.X2)
  Else
    ControlRecord(MaxControl).Top = inControl.Top
    ControlRecord(MaxControl).Left = ActualPos(inControl.Left)
    ControlRecord(MaxControl).Height = inControl.Height
    ControlRecord(MaxControl).Width = inControl.Width
  End If

  inControl.IntegralHeight = False
  
  On Error GoTo 0
  AddControl = MaxControl
  MaxControl = MaxControl + 1
End Function

Private Function PerWidth(pfrmIn As Form) As Long
  Dim i As Long
  
  i = FindForm(pfrmIn)
  If i < 0 Then i = AddForm(pfrmIn)
  
  PerWidth = (pfrmIn.ScaleWidth * 100) \ FormRecord(i).ScaleWidth
End Function

Private Function PerHeight(pfrmIn As Form) As Single
  Dim i As Long
  
  i = FindForm(pfrmIn)
  If i < 0 Then i = AddForm(pfrmIn)
  
  PerHeight = (pfrmIn.ScaleHeight * 100) \ FormRecord(i).ScaleHeight
End Function

Private Sub ResizeControl(inControl As Control, pfrmIn As Form)
  On Error Resume Next
  Dim i As Long
  Dim widthfactor As Single, heightfactor As Single
  Dim minFactor As Single
  Dim yRatio, xRatio, lTop, lLeft, lWidth, lHeight As Long
  
  yRatio = PerHeight(pfrmIn)
  xRatio = PerWidth(pfrmIn)
  i = FindControl(inControl, pfrmIn.Name)

  If inControl.Left < 0 Then
    lLeft = CLng(((ControlRecord(i).Left * xRatio) \ 100) - 75000)
  Else
    lLeft = CLng((ControlRecord(i).Left * xRatio) \ 100)
  End If

  lTop = CLng((ControlRecord(i).Top * yRatio) \ 100)
  lWidth = CLng((ControlRecord(i).Width * xRatio) \ 100)
  lHeight = CLng((ControlRecord(i).Height * yRatio) \ 100)
  
  If TypeOf inControl Is Line Then
    If inControl.X1 < 0 Then
      inControl.X1 = CLng(((ControlRecord(i).Left * xRatio) \ 100) - 75000)
    Else
      inControl.X1 = CLng((ControlRecord(i).Left * xRatio) \ 100)
    End If
    
    inControl.Y1 = CLng((ControlRecord(i).Top * yRatio) \ 100)
    If inControl.X2 < 0 Then
      inControl.X2 = CLng(((ControlRecord(i).Width * xRatio) \ 100) - 75000)
    Else
      inControl.X2 = CLng((ControlRecord(i).Width * xRatio) \ 100)
    End If

    inControl.Y2 = CLng((ControlRecord(i).Height * yRatio) \ 100)
  Else
    inControl.Move lLeft, lTop, lWidth, lHeight
    inControl.Move lLeft, lTop, lWidth
    inControl.Move lLeft, lTop
  End If
End Sub

Public Sub ResizeForm(pfrmIn As Form)
  Dim FormControl As Control
  Dim isVisible As Boolean
  Dim StartX, StartY, MaxX, MaxY As Long
  Dim bNew As Boolean
  
  If Not bRunning Then
    bRunning = True
    
    If FindForm(pfrmIn) < 0 Then
      bNew = True
    Else
      bNew = False
    End If

    If pfrmIn.Top < 30000 Then
      isVisible = pfrmIn.Visible
      On Error Resume Next
      
      If Not pfrmIn.MDIChild Then
        On Error GoTo 0
        'pfrmIn.Visible = False
      Else
        If bNew Then
          StartY = pfrmIn.Height
          StartX = pfrmIn.Width
          On Error Resume Next

          For Each FormControl In pfrmIn
            If FormControl.Left + FormControl.Width + 200 > MaxX Then _
              MaxX = FormControl.Left + FormControl.Width + 200
            If FormControl.Top + FormControl.Height + 500 > MaxY Then _
              MaxY = FormControl.Top + FormControl.Height + 500
            If FormControl.X1 + 200 > MaxX Then _
              MaxX = FormControl.X1 + 200
            If FormControl.Y1 + 500 > MaxY Then _
              MaxY = FormControl.Y1 + 500
            If FormControl.X2 + 200 > MaxX Then _
              MaxX = FormControl.X2 + 200
            If FormControl.Y2 + 500 > MaxY Then _
              MaxY = FormControl.Y2 + 500
          Next FormControl
          On Error GoTo 0
          
          pfrmIn.Height = MaxY
          pfrmIn.Width = MaxX
        End If
        On Error GoTo 0

      End If
      
      For Each FormControl In pfrmIn
        ResizeControl FormControl, pfrmIn
      Next FormControl
      On Error Resume Next

      If Not pfrmIn.MDIChild Then
        On Error GoTo 0
        pfrmIn.Visible = isVisible
      Else
        If bNew Then
          pfrmIn.Height = StartY
          pfrmIn.Width = StartX
          
          For Each FormControl In pfrmIn
            ResizeControl FormControl, pfrmIn
          Next FormControl
        End If
      End If
      On Error GoTo 0
      
    End If
    bRunning = False
  End If
End Sub

Public Sub SaveFormPosition(pfrmIn As Form)
  Dim i As Long

  If MaxForm > 0 Then
    For i = 0 To (MaxForm - 1)
      If FormRecord(i).Name = pfrmIn.Name Then
        FormRecord(i).Top = pfrmIn.Top
        FormRecord(i).Left = pfrmIn.Left
        FormRecord(i).Height = pfrmIn.Height
        FormRecord(i).Width = pfrmIn.Width
        Exit Sub
      End If
    Next i
    AddForm (pfrmIn)
  End If
End Sub

Public Sub RestoreFormPosition(pfrmIn As Form)
  Dim i As Long

  If MaxForm > 0 Then
    For i = 0 To (MaxForm - 1)
      If FormRecord(i).Name = pfrmIn.Name Then
        If FormRecord(i).Top < 0 Then
          pfrmIn.WindowState = 2
        ElseIf FormRecord(i).Top < 30000 Then
          pfrmIn.WindowState = 0
          pfrmIn.Move FormRecord(i).Left, FormRecord(i).Top, FormRecord(i).Width, FormRecord(i).Height
        Else
          pfrmIn.WindowState = 1
        End If
        Exit Sub
      End If
    Next i
  End If
End Sub 


حالا همه كدها را پاك كنيد و اين را paste كنيد

کد php:

Private Sub Form_Resize()
  ResizeForm Me
End Sub 


---

عمل undo براي textBox

کد php:

Private Const EM_UNDO = &HC7
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Any) As Long 


کد php:

Private Sub Form_Click()
SendMessage Text1.hwnd, EM_UNDO, 0, ByVal CStr(0)
End Sub

Private Sub Form_Load()
Text1.Text = "قسمتي از متن را تغيير بدهيد سپس روي فرم كليك كنيد و انجام عمل Undo را در متن خواهيد ديد"
End Sub 


---

نشان دادنfont در يك كمبو

کد php:

Const CB_FINDSTRING = &H14C
Private Declare Function SendMessageAny Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const CB_SHOWDROPDOWN = &H14F

Public Function ComboBoxIndex(ByVal lHwnd As Long, ByVal sSearchText As String) As Long
ComboBoxIndex = SendMessageAny(lHwnd, CB_FINDSTRING, -1, ByVal sSearchText)
End Function

Private Sub Combo1_Change()
r = SendMessageLong(Combo1.hwnd, CB_SHOWDROPDOWN, True, 0)
ComboBoxIndex Combo1.hwnd, Combo1.Text
End Sub 


کد php:

'در فرم ريخته شود
Private Sub Command1_Click()
Text1.FontName = Combo1.Text
End Sub

Private Sub Form_Load()
For i = 0 To Screen.FontCount - 1
Combo1.AddItem Screen.Fonts(i)
Next i
Combo1.Text = Screen.Fonts(0)
End Sub 


---

تمام كدهاي اين مجموعه تست شده و همگي سالم هستند فقط شما بي معرفتا كه نظر نمي دهيد

[skh1300]

ocx براي كار با جست جوي فايل

---

يك چارت كه از زبان فارسي پشتيباني نمي كرد كه من با دستكاري كدها حالا فارسي مي تونيد بنويسيد(فارسي درست شد.)

---

كنترلي براي resize كردن كنترل به همراه فونت و...
دانلود نكني از دست رفته

---

تمام اين كنترل ها كرك شده هستند

[skh1300]

گذاشتن بك گراند براي منو (خيلي قشنگه)

---

گذاشتن بك گراند براي فرم هاي mdi

---

مثال هاي بسيار عالي از rich Text box

---

فرمي درون فرم ديگر

[skh1300]

كار ماسك براي عكس

[skh1300]

اينم چند زباني كردن برنامه (بسيار مفيد)

[skh1300]

نشان دان پنجره اي كه كاربر داره با اون كار مكنه

دوستان هم ياري كنن كه مطالب متنوع از هركس ببينيم الان همش من گذاشتم شما هم بزارين

[skh1300]

نمايش sin و cos روي نمودار به صورت سه بعدي

[skh1300]

بزرگنمايي عكس