در تاپیک ((آموزش مصور ویژوال بیسیک )) در این پست یک بسته سورس معرفی شد.
می خواهیم در این تاپیک این سورسها را مورد بررسی قرار دهیم.
از سایتها هم اگر سورس جالبی پیدا شد اینجا بحث می کنیم.
یعنی این فایل exe در toaster (برشته کننده نان) هم اجرا میشه ولی من toaster نداشتم تا امتحان کنم.
کل کد اینه:
کد:
Private Sub cmdCreate_Click()
Call MakeEXE
End Sub
Private Sub MakeEXE()
Dim tempInt As Integer
On Error GoTo ErrorHandler
Open txtOutput.Text For Binary Access Write As #1
'// Put some stuff in the file so the cpu knows what to do
'basically just some assembly machine code.//
Put #1, 1, 180
Put #1, 2, 9
Put #1, 3, 186
Put #1, 4, 9
Put #1, 5, 1
Put #1, 6, 205
Put #1, 7, 33
Put #1, 8, 195
Put #1, 9, 32
'// Insert your message //
For i = 1 To Len(txtBody.Text)
tempInt = Asc(Mid(txtBody.Text, i, 1))
Put #1, i + 9, tempInt
Next i
'// Put the footer //
Put #1, Len(txtBody.Text) + 10, 36
Close #1
MsgBox "EXE Compiled and Linked.", vbInformation, "Finished."
Exit Sub
ErrorHandler:
MsgBox "There was an error.", vbCritical, "Error"
End Sub
Private Sub Form_Load()
MsgBox "Please do not vote for this, just please leave a comment. This code was written by me, but the idea was from Vbmew (http://www.planetsourcecode.com/vb/scripts/ShowCode.asp?txtCodeId=2232&lngWId=3), so please check it out!", vbInformation, "About"
End Sub
نتیجه اجرا:
چیزی که در نگاه اول بدون بررسی کدها من دیدم این بود که در درایو C یک فایل ساخته شد که از داخل کامنت پرومپت اجرا میشد و چیزهایی که در برنامه وی بی داخل تکست باکس وارد کرده بودیم را نشان می داد.
از پوشه دوم پست قبلی پروژه اولی خطا داد. بماند برای بعد.
دومی اجرا شد.
کد فرم و ماژول آن این است:
کد:
'If you are going to use this in a app, you must
'first contact me at [email protected], and you
'have to credit me on the application's box, and/or
'about box
Private Sub Command1_Click()
On Error GoTo UsrCancel
CommonDialog1.CancelError = True
CommonDialog1.Filter = "Executable Files|*.exe|"
CommonDialog1.Flags = cdlOFNFileMustExist
CommonDialog1.ShowOpen
If CommonDialog1.FileName = "" Then Exit Sub
Text1 = CommonDialog1.FileName
UsrCancel:
End Sub
Private Sub Command2_Click()
On Error GoTo UsrCancel
CommonDialog1.CancelError = True
CommonDialog1.Filter = "All Files|*.*|"
CommonDialog1.Flags = cdlOFNFileMustExist
CommonDialog1.ShowOpen
If CommonDialog1.FileName = "" Then Exit Sub
Text2 = CommonDialog1.FileName
UsrCancel:
End Sub
Private Sub Command3_Click()
'check something first...
If Len(Text1) = 0 Or Len(Text2) = 0 Then 'assure that the 2 textboxes are not empty
Beep
Exit Sub
End If
If Dir(Text1) = "" Or Dir(Text2) = "" Then
MsgBox "One or all of the files you entered do not exist!", vbCritical, "Error"
Exit Sub
End If
'if everything is ok continue...
AddToSelfExtract Text1, Text2, Text3
MsgBox "Done!", vbInformation, "Done!"
End Sub
Private Sub Command4_Click()
On Error GoTo UsrCancel
CommonDialog1.CancelError = True
CommonDialog1.Filter = "Executable Files|*.exe|"
CommonDialog1.Flags = cdlOFNCreatePrompt Or cdlOFNOverwritePrompt
CommonDialog1.ShowSave
If CommonDialog1.FileName = "" Then Exit Sub
Text3 = CommonDialog1.FileName
UsrCancel:
End Sub
Private Sub Command5_Click()
End
End Sub
کد:
'If you are going to use this in a app, you must
'first contact me at [email protected], and you
'have to credit me on the application's box, and/or
'about box
Sub AddToSelfExtract(SelfExtract As String, WhatFile As String, SaveAs As String)
Dim iFreeFile As Integer
Dim iFreeFile2 As Integer
Dim sBuffer As String
Dim sBefore As String
iFreeFile = FreeFile
Open SelfExtract For Binary As iFreeFile
sBefore = String(LOF(iFreeFile), Chr(0))
Get iFreeFile, , sBefore
Close iFreeFile
Open SaveAs For Output As iFreeFile
iFreeFile2 = FreeFile
Open WhatFile For Binary As iFreeFile2
sBuffer = String(LOF(iFreeFile2), Chr(0))
Get iFreeFile2, , sBuffer
Size = LOF(iFreeFile2)
Size = String(10 - Len(Size), "0") & Size
Print #iFreeFile, sBefore & sBuffer & Size
Close iFreeFile2
Close iFreeFile
End Sub
اولی بی خطا اجرا شد. با تصویر و کد زیر(فقط یک فرم دارد):
کد:
Option Explicit
' Shfileop sample from BlackBeltVB.com
' http://blackbeltvb.com
'
' Written by Matt Hart
' Copyright 1999 by Matt Hart
'
' This software is FREEWARE. You may use it as you see fit for
' your own projects but you may not re-sell the original or the
' source code. Do not copy this sample to a collection, such as
' a CD-ROM archive. You may link directly to the original sample
' using "http://blackbeltvb.com/shfileop.htm"
'
' No warranty express or implied, is given as to the use of this
' program. Use at your own risk.
'
' This program shows how to implement the SHFileOperation API.
' You can use it to delete, move, or copy multiple or single files,
' and it can send files to the recycle bin.
Private Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As Long
lpszProgressTitle As String ' only used if FOF_SIMPLEPROGRESS
End Type
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
' // Shell File Operations
Const FO_MOVE = &H1
Const FO_COPY = &H2
Const FO_DELETE = &H3
Const FO_RENAME = &H4
Const FOF_MULTIDESTFILES = &H1
Const FOF_CONFIRMMOUSE = &H2
Const FOF_SILENT = &H4 ' don't create progress/report
Const FOF_RENAMEONCOLLISION = &H8
Const FOF_NOCONFIRMATION = &H10 ' Don't prompt the user.
Const FOF_WANTMAPPINGHANDLE = &H20 ' Fill in SHFILEOPSTRUCT.hNameMappings
' Must be freed using SHFreeNameMappings
Const FOF_ALLOWUNDO = &H40
Const FOF_FILESONLY = &H80 ' on *.*, do only files
Const FOF_SIMPLEPROGRESS = &H100 ' means don't show names of files
Const FOF_NOCONFIRMMKDIR = &H200 ' don't confirm making any needed dirs
Const PO_DELETE = &H13 ' printer is being deleted
Const PO_RENAME = &H14 ' printer is being renamed
Const PO_PORTCHANGE = &H20 ' port this printer connected to is being changed
' if this id is set, the strings received by
' the copyhook are a doubly-null terminated
' list of strings. The first is the printer
' name and the second is the printer port.
Const PO_REN_PORT = &H34 ' PO_RENAME and PO_PORTCHANGE at same time.
Private Sub Check1_Click(Index As Integer)
If Check1(2).Value = 0 Then
Check1(3).Enabled = False
Text2.Enabled = False
Else
Check1(3).Enabled = True
Text2.Enabled = True
End If
End Sub
' no POF_ flags currently defined
' implicit parameters are:
' if pFrom or pTo are unqualified names the current directories are
' taken from the global current drive/directory settings managed
' by Get/SetCurrentDrive/Directory
'
' the global confirmation settings
Private Sub Command1_Click()
Dim lResult As Long, SHF As SHFILEOPSTRUCT
SHF.hwnd = hwnd
SHF.wFunc = FO_DELETE
SHF.pFrom = Text1.Text
SHF.fFlags = FOF_FILESONLY
If Check1(0).Value = 0 Then SHF.fFlags = SHF.fFlags + FOF_ALLOWUNDO
If Check1(1).Value = 0 Then SHF.fFlags = SHF.fFlags + FOF_NOCONFIRMATION
If Check1(2).Value = 0 Then
SHF.fFlags = SHF.fFlags + FOF_SILENT
Else
If Check1(3).Value Then SHF.fFlags = SHF.fFlags + FOF_SIMPLEPROGRESS
SHF.lpszProgressTitle = Text2.Text
End If
lResult = SHFileOperation(SHF)
If lResult Then
MsgBox "Error occurred!"
End If
End Sub
Private Sub Form_Load()
Move (Screen.Width - Width) \ 2, (Screen.Height - Height) \ 2
End Sub
========================
دومی هم اجرا شد.با عکس و کد فرم و ماژول و کلاس ماژول زیر:
کد:
' File: vbshell.frm
' Copyright 1998 Andrew S. Dean
Option Explicit
Private Sub cmdAddNotepadShell_Click()
fCreateShellGroup "VBShell Demo"
CreateShellLink "VBShell Demo", "Run Notepad", "C:\windows\notepad.exe", ""
End Sub
Private Sub cmdAddNotepadStartup_Click()
' Add the file to start when Windows starts.
CreateShellLink "StartUp", "Run Notepad", "C:\windows\notepad.exe", ""
End Sub
Private Sub cmdAddRecentDocs_Click()
AddToRecentDocs txtRecentDoc.Text
End Sub
Private Sub cmdDeleteAssoc_Click()
Dim clsFileAssoc As New CFileAssociation
With clsFileAssoc
.strExt = txtExt
.strAppID = txtID
End With
clsFileAssoc.DeleteAssociation
End Sub
Private Sub cmdGetAssoc_Click()
Dim strExt As String
strExt = Text1.Text
MsgBox GetFileAssociation(strExt)
End Sub
Private Sub cmdGetShellFolder_Click()
Dim strTemp As String
strTemp = GetShellFolder(cboShellFolderName.Text)
MsgBox strTemp
End Sub
Private Sub cmdJunkIt_Click()
CopyFile txtFilename, "c:\junk.old"
End Sub
Private Sub cmdRecycleFile_Click()
RemoveFile txtFilename.Text
End Sub
Private Sub cmdSetAssoc_Click()
Dim clsFileAssoc As New CFileAssociation
With clsFileAssoc
.strExt = txtExt
.strAppID = txtID
.strOpenCommand = txtOpen
.strExePath = App.Path & "\" & App.EXEName & ".exe"
.strFileType = txtFileLabel
' .strIcon = "0"
.strNewFileType = "NullFile"
End With
clsFileAssoc.CreateAssociation
clsFileAssoc.CreateContextMenuItem "foobar", "C:\windows\notepad.exe %1"
End Sub
Private Sub Form_Load()
cboShellFolderName.AddItem "Personal"
cboShellFolderName.AddItem "Desktop"
cboShellFolderName.AddItem "NetHood"
cboShellFolderName.AddItem "Programs"
cboShellFolderName.AddItem "Start Menu"
cboShellFolderName.AddItem "StartUp"
cboShellFolderName.AddItem "Favorites"
cboShellFolderName.AddItem "Fonts"
cboShellFolderName.AddItem "Recent"
cboShellFolderName.AddItem "Sendto"
cboShellFolderName.AddItem "Templates"
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Select Case UnloadMode
Case vbAppWindows
' If the app is being closed because Windows is being closed,
' we write the registry settings that will cause
' the program to start up again when Windows starts up.
Dim lResult As Long
Dim hKey As Long
Dim strRunCmd As String
strRunCmd = App.Path & "\" & App.EXEName & ".exe"
lResult = RegCreateKey(HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\RunOnce", hKey)
lResult = RegSetValueEx(hKey, App.EXEName, 0&, REG_SZ, ByVal strRunCmd, Len(strRunCmd))
lResult = RegCloseKey(hKey)
Case Else
' Just fall through
End Select
End Sub
کد:
'File: vbshell.bas
' Copyright 1998 Andrew S. Dean
Option Explicit
' For adding files to the Recent Documents menu.
Declare Sub SHAddToRecentDocs Lib "Shell32" (ByVal uFlags As Long, ByVal lpBuffer As String)
'Global Const SHARD_PIDL = 1
Global Const SHARD_PATHA = 2
Global Const SHARD_PATHW = 3
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' For adding files to the Recycle Bin, etc.
Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As Long
lpszProgressTitle As String ' only used if FOF_SIMPLEPROGRESS
End Type
Declare Function SHFileOperation Lib "Shell32" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
' SHFileOperation wFunc settings
Public Const FO_COPY = &H2
Public Const FO_DELETE = &H3
Public Const FO_MOVE = &H1
Public Const FO_RENAME = &H4
' SHFileOperation fFlag settings
Public Const FOF_ALLOWUNDO = &H40
Public Const FOF_CONFIRMMOUSE = &H2
Public Const FOF_FILESONLY = &H80
Public Const FOF_MULTIDESTFILES = &H1
Public Const FOF_NOCONFIRMATION = &H10
Public Const FOF_NOCONFIRMMKDIR = &H200
Public Const FOF_RENAMEONCOLLISION = &H8
Public Const FOF_SILENT = &H4
Public Const FOF_SIMPLEPROGRESS = &H100
Public Const FOF_WANTMAPPINGHANDLE = &H20
''''''''''''''''''''''''''''''''''''''''''''''''''
' Registry functions
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const REG_SZ = 1 ' String data type
Public Const SYNCHRONIZE = &H100000
' Reg Key Security Options
Public Const READ_CONTROL = &H20000
Public Const KEY_QUERY_VALUE = &H1
Public Const KEY_SET_VALUE = &H2
Public Const KEY_CREATE_SUB_KEY = &H4
Public Const KEY_ENUMERATE_SUB_KEYS = &H8
Public Const KEY_NOTIFY = &H10
Public Const KEY_CREATE_LINK = &H20
Public Const STANDARD_RIGHTS_READ = (READ_CONTROL)
Public Const STANDARD_RIGHTS_WRITE = (READ_CONTROL)
Public Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Public Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
Public Const KEY_EXECUTE = (KEY_READ)
Public Const STANDARD_RIGHTS_ALL = &H1F0000
Public Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
Declare Function RegCreateKey Lib "advapi32.dll" _
Alias "RegCreateKeyA" _
(ByVal hKey As Long, ByVal lpctstr As String, _
phkey As Long) As Long
Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Declare Function RegSetValueEx Lib "advapi32.dll" _
Alias "RegSetValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, _
lpData As Any, ByVal cbData As Long) As Long
Declare Function RegDeleteKey Lib "advapi32.dll" _
Alias "RegDeleteKeyA" _
(ByVal hKey As Long, ByVal lpszSubkey As String) _
As Long
Declare Function RegOpenKeyEx Lib "advapi32.dll" _
Alias "RegOpenKeyExA" _
(ByVal hKey As Long, ByVal lpSubkey As String, _
ByVal ulOptions As Long, ByVal samDesired As Long, _
phkResult As Long) As Long
Declare Function RegQueryValueEx Lib "advapi32.dll" _
Alias "RegQueryValueExA" _
(ByVal hKey As Long, ByVal lpszValueName As String, _
ByVal lpdwReserved As Long, lpdwType As Long, _
lpData As Any, lpcbData As Long) As Long
' Definition of lpdwReserved modified by adding BYVAL
''''''''''''''''''''''''''''''''''''''''''''''''''
' From VB5 Setup Kit
Declare Function OSfCreateShellLink Lib "VB5STKIT.DLL" Alias "fCreateShellLink" (ByVal lpstrFolderName As String, ByVal lpstrLinkName As String, ByVal lpstrLinkPath As String, ByVal lpstrLinkArguments As String) As Long
Declare Function OSfCreateShellGroup Lib "VB5STKIT.DLL" Alias "fCreateShellFolder" (ByVal lpstrDirName As String) As Long
Declare Function OSfRemoveShellLink Lib "VB5STKIT.DLL" Alias "fRemoveShellLink" (ByVal lpstrFolderName As String, ByVal lpstrLinkName As String) As Long
Sub Main()
If Command() <> "" Then
Dim CurChar As String
Dim CmdLine As String
Dim CmdLineLen As Long
Dim NumArgs As Integer
Dim InArg As Integer
Dim PosInStr As Integer
Dim strMsg As String
Dim ArgArray() As String
'Get command line arguments.
CmdLine = Command()
CmdLineLen = Len(CmdLine)
' Initialize counters and flags
NumArgs = 0
InArg = False
ReDim ArgArray(NumArgs)
' Go thru command line one character at a time.
' We assume that a Space or Tab character is used as the delimiter.
For PosInStr = 1 To CmdLineLen
CurChar = Mid(CmdLine, PosInStr, 1)
'Test for space or tab.
If (CurChar <> " " And CurChar <> vbTab) Then
'Neither space nor tab. Test if already building argument.
If Not InArg Then
'Begin new argument.
NumArgs = NumArgs + 1
InArg = True
End If
'Add character to end of current argument.
ArgArray(NumArgs - 1) = ArgArray(NumArgs - 1) & CurChar
Else
'Found a space or tab. Set InArg flag to False.
InArg = False
ReDim Preserve ArgArray(NumArgs)
End If
Next PosInStr
Dim I As Integer
For I = 0 To NumArgs - 1
strMsg = strMsg & "> " & ArgArray(I) & vbCrLf
Next I
MsgBox "Command line arguments: " & vbCrLf & strMsg
End If
frmVBShell.Show
End Sub
' Move a file to the recycle bin.
Function RemoveFile(strFile As String) As Long
Dim SHFileOp As SHFILEOPSTRUCT
With SHFileOp
.wFunc = FO_DELETE
.pFrom = strFile
.fFlags = FOF_ALLOWUNDO
End With
RemoveFile = SHFileOperation(SHFileOp)
End Function
' Copy a file, displaying a progress window.
Function CopyFile(strFileOld As String, strFileNew As String) As Long
Dim SHFileOp As SHFILEOPSTRUCT
With SHFileOp
.wFunc = FO_COPY
.pFrom = strFileOld
.pTo = strFileNew
End With
CopyFile = SHFileOperation(SHFileOp)
End Function
Sub AddToRecentDocs(strFile As String)
On Error Resume Next
' Win 95 does not use UNICODE. NT uses UNICODE by default.
' VB always uses UNICODE internally, but converts as necessary.
' This is great because it doesn't add duplicates and it
' does not add items that are not valid file names.
' It appears that this doesn't work if File Type has
' not been defined for the file extension (ie, the
' default value of the AppID key has not be set.
SHAddToRecentDocs SHARD_PATHA, ByVal strFile
End Sub
Sub DeleteKey(szKey As String)
Dim lResult As String
Dim hKey As Long
If szKey <> "" Then
lResult = RegDeleteKey(HKEY_CLASSES_ROOT, szKey)
End If
End Sub
''''''''''''''''''''''''
' This routine sets up a file association so that a file
' can be opened by an application by double clicking on the
' file in Explorer.
' A file to use as an empty file will also be registered,
' so that a new file of this type can be created by clicking
' on the new menu in Explorer, on the desktop, etc.
'''''''''''''''''''''''''
Sub SetFileAssociation(strExt As String, strAppID As String, strCommand As String, strEmptyFile As String, strFileLabel As String, strIcon As String)
' strExt is the file extension
' strAppID is the Application Identifier.
' strCommand is the Open Command
' strEmptyFile is the file to use to create new files.
' strFileLabel is the string displayed in the various New menus.
' We want to create
' .ext -> AppID
' ShellNew
' FileName -> strNewValue
' AppID -> FileLabel
' and then some...
Dim lResult As Long
Dim hKey As Long
Dim strValueName As String
'' IT APPEARS FROM LOOKING AT OTHER ENTRIES THAT LONG FILE NAMES
'' MIGHT NOT BE VALID IN THE COMMAND? TEST THIS!!!
lResult = RegCreateKey(HKEY_CLASSES_ROOT, strExt, hKey)
Debug.Assert lResult = 0
'strValueName = ""
' lResult = RegSetValueEx(hKey, strValueName, 0, REG_SZ, ByVal strAppID, Len(strAppID))
lResult = RegSetValueEx(hKey, vbNullString, 0, REG_SZ, ByVal strAppID, Len(strAppID))
Debug.Assert lResult = 0
If strEmptyFile <> "" Then
Dim strKey As String
strKey = strExt & "\" & "ShellNew"
lResult = RegCreateKey(HKEY_CLASSES_ROOT, strKey, hKey)
Debug.Assert lResult = 0
' This could be either FileName, Command, or Data
' It should be an argument of the function.
strValueName = "FileName"
lResult = RegSetValueEx(hKey, strValueName, 0, REG_SZ, ByVal strEmptyFile, Len(strEmptyFile))
Debug.Assert lResult = 0
lResult = RegCloseKey(hKey)
Debug.Assert lResult = 0
End If
'' HOW IMPORTANT IS IT TO CLOSE THE KEY????
Dim strTemp As String
lResult = RegCreateKey(HKEY_CLASSES_ROOT, strAppID, hKey)
If strFileLabel <> "" Then
'strValueName = ""
lResult = RegSetValueEx(hKey, vbNullString, 0, REG_SZ, ByVal strFileLabel, Len(strFileLabel))
End If
lResult = RegCloseKey(hKey)
strTemp = strAppID & "\shell\open\command"
lResult = RegCreateKey(HKEY_CLASSES_ROOT, strTemp, hKey)
'strValueName = ""
'lResult = RegSetValueEx(hKey, strValueName, 0, REG_SZ, ByVal strCommand, Len(strCommand))
lResult = RegSetValueEx(hKey, vbNullString, 0, REG_SZ, ByVal strCommand, Len(strCommand))
lResult = RegCloseKey(hKey)
Debug.Assert lResult = 0
' Register the default Icon
If strIcon <> "" Then
strTemp = strAppID & "\DefaultIcon"
lResult = RegCreateKey(HKEY_CLASSES_ROOT, strTemp, hKey)
strValueName = ""
' If the icon was passed in as a number, assume the
' DefaultIcon is supposed to be "this.exe,1"
' Otherwise, assume the entire file and icon number was used.
If IsNumeric(strIcon) Then
strTemp = App.Path & "\" & App.EXEName & ".exe," & strIcon
Else
strTemp = strIcon
End If
lResult = RegSetValueEx(hKey, strValueName, 0, REG_SZ, ByVal strTemp, Len(strTemp))
Debug.Assert lResult = 0
lResult = RegCloseKey(hKey)
Debug.Assert lResult = 0
End If
End Sub
Function GetShellFolder(szFolder As String) As String
Dim lResult As Long
Dim strKey As String
Dim hKey As Long
Dim strBuffer As String
Dim lLen As Long
' A better approach than this (language independent, for example), would be to use
' the SHGetSpecialFolderLocation() function, and pass the appropriate CSIDL constant.
' CSIDL constants are defined in shlobj.h, a Windows Header File.
'
strKey = "Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders"
' Public Const KEY_QUERY_VALUE = &H1
lResult = RegOpenKeyEx(HKEY_CURRENT_USER, strKey, 0, KEY_QUERY_VALUE, hKey)
If lResult <> 0 Then
GetShellFolder = ""
Exit Function
End If
strBuffer = Space$(1024)
lLen = Len(strBuffer)
lResult = RegQueryValueEx(hKey, szFolder, 0, REG_SZ, ByVal strBuffer, lLen)
If lResult <> 0 Then
GetShellFolder = ""
Exit Function
End If
' Might still want to verify that lLen > 0
GetShellFolder = Left$(strBuffer, lLen - 1)
End Function
Function GetFileAssociation(strExt As String) As String
Dim hKey As Long
Dim strBuffer As String
Dim strTemp As String
Dim lResult As Long
lResult = RegOpenKeyEx(HKEY_CLASSES_ROOT, strExt, 0, KEY_READ, hKey)
If lResult <> 0 Then
GetFileAssociation = "Unregistered file extension " & strExt
Exit Function
End If
Dim lLen As Long
Dim strValueName As String
strValueName = ""
Dim lType As Long
lType = REG_SZ
strBuffer = Space$(128)
lLen = Len(strBuffer)
lResult = RegQueryValueEx(hKey, strValueName, 0, REG_SZ, ByVal strBuffer, lLen)
Debug.Print lResult
Debug.Print lType
Debug.Print lLen
'lResult = RegQueryValue(hKey, strValueName, ByVal strBuffer, lLen)
'lResult = RegQueryValue(hKey, ByVal strValueName, ByVal 0, lLen)
If lResult <> 0 Then
MsgBox lResult
Exit Function
End If
strTemp = Mid$(strBuffer, 1, lLen - 1)
Debug.Print strTemp
strTemp = strTemp & "\shell\open\command"
lResult = RegOpenKeyEx(HKEY_CLASSES_ROOT, strTemp, 0, KEY_READ, hKey)
If lResult <> 0 Then
GetFileAssociation = "File type is not associated with a program."
Exit Function
End If
lLen = Len(strBuffer)
strValueName = ""
lResult = RegQueryValueEx(hKey, strValueName, 0, REG_SZ, ByVal strBuffer, lLen)
strTemp = Mid$(strBuffer, 1, lLen - 1)
GetFileAssociation = strTemp
End Function
''''''''''''''''''
' From VB5 Setup Kit:
'-----------------------------------------------------------
' SUB: CreateShellLink
'
' Creates (or replaces) a link in either Start>Programs or
' any of its immediate subfolders in the Windows 95 shell.
'
' IN: [strLinkPath] - full path to the target of the link
' Ex: 'c:\Program Files\My Application\MyApp.exe"
' [strLinkArguments] - command-line arguments for the link
' Ex: '-f -c "c:\Program Files\My Application\MyApp.dat" -q'
' [strLinkName] - text caption for the link
' [fLog] - Whether or not to write to the logfile (default
' is true if missing)
'
' OUT:
' The link will be created in the folder strGroupName
' You can edit these manually with Explorer in the
' Windows\StartMenu\ directory.
'-----------------------------------------------------------
Sub CreateShellLink(ByVal strGroupName As String, ByVal strLinkName As String, ByVal strLinkPath As String, ByVal strLinkArguments As String)
strLinkName = strUnQuoteString(strLinkName)
strLinkPath = strUnQuoteString(strLinkPath)
Dim fSuccess As Boolean
fSuccess = OSfCreateShellLink(strGroupName, strLinkName, strLinkPath, strLinkArguments) 'the path should never be enclosed in double quotes
If Not fSuccess Then
MsgBox "Couldn't create link"
End If
End Sub
'-----------------------------------------------------------
' SUB: fCreateShellGroup
'
' Creates a new program group off of Start>Programs in the
' Windows 95 shell if the specified folder doesn't already exist.
'
'-----------------------------------------------------------
Function fCreateShellGroup(ByVal strFolderName As String) As Boolean
ReplaceDoubleQuotes strFolderName
If strFolderName = "" Then
Exit Function
End If
Dim fSuccess As Boolean
fSuccess = OSfCreateShellGroup(strFolderName)
fCreateShellGroup = fSuccess
End Function
'-----------------------------------------------------------
' SUB: RemoveShellLink
'
' Removes a link in either Start>Programs or any of its
' immediate subfolders in the Windows 95 shell.
'
' IN: [strFolderName] - text name of the immediate folder
' in which the link to be removed
' currently exists, or else the
' empty string ("") to indicate that
' the link can be found directly in
' the Start>Programs menu.
' [strLinkName] - text caption for the link
'
' This action is never logged in the app removal logfile.
'
' PRECONDITION: strFolderName has already been created and is
' an immediate subfolder of Start>Programs, if it
' is not equal to ""
'-----------------------------------------------------------
'
Sub RemoveShellLink(ByVal strFolderName As String, ByVal strLinkName As String)
Dim fSuccess As Boolean
ReplaceDoubleQuotes strFolderName
ReplaceDoubleQuotes strLinkName
fSuccess = OSfRemoveShellLink(strFolderName, strLinkName)
End Sub
' Replace all double quotes with single quotes
Public Sub ReplaceDoubleQuotes(str As String)
Dim I As Integer
For I = 1 To Len(str)
If Mid$(str, I, 1) = """" Then
Mid$(str, I, 1) = "'"
End If
Next I
End Sub
Public Function strUnQuoteString(ByVal strQuotedString As String)
'
' This routine tests to see if strQuotedString is wrapped in quotation
' marks, and, if so, remove them.
'
strQuotedString = Trim(strQuotedString)
Dim strQUOTE As String
strQUOTE = """"
If Mid$(strQuotedString, 1, 1) = strQUOTE And Right$(strQuotedString, 1) = strQUOTE Then
'
' It's quoted. Get rid of the quotes.
'
strQuotedString = Mid$(strQuotedString, 2, Len(strQuotedString) - 2)
End If
strUnQuoteString = strQuotedString
End Function
کد:
'File: CFileAss.cls
' CFileAssociation class for VB
' Copyright 1998 Andrew S. Dean
Option Explicit
' Public properties for the FileAssociation Class.
Public strExt As String ' .txt
Public strAppID As String ' txtfile
Public strOpenCommand As String ' C:\windows\notepad.exe %1
Public strFileType As String ' Text Document
Public strIcon As String ' c:\windows\notepad.exe,0
Public strNewFileType As String ' NullFile, FileName, Command (or Data)
Public strNewFileCommand As String
Public strExePath As String ' c:\windows\notepad.exe
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Creates
' HKEY_CLASSES_ROOT
' .ext -> AppID
' ShellNew
' FileName -> strNewValue
' AppID -> FileLabel
' shell
' open
' command -> strOpenCommand
' and then some...
'
' Of course robust error handling should be added!
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function CreateAssociation() As Long
If strExt = "" Or strAppID = "" Then
CreateAssociation = 1
Exit Function
End If
Dim lResult As Long
Dim hKey As Long
Dim strValueName As String
Dim strKey As String
' Create
' HKEY_CLASSES_ROOT
' .ext -> AppID
lResult = RegCreateKey(HKEY_CLASSES_ROOT, strExt, hKey)
lResult = RegSetValueEx(hKey, vbNullString, 0, REG_SZ, ByVal strAppID, Len(strAppID))
' Create
' HKEY_CLASSES_ROOT
' .ext
' ShellNew
' FileName -> strNewFile
' Don't handle the Date file type yet...
If strNewFileType = "NullFile" Or strNewFileType = "Command" Or strNewFileType = "FileName" Then
strKey = strExt & "\" & "ShellNew"
lResult = RegCreateKey(HKEY_CLASSES_ROOT, strKey, hKey)
' This could be either NullFile, FileName, Command, or Data
strValueName = strNewFileType
If strValueName = "NullFile" Then
strNewFileCommand = ""
End If
lResult = RegSetValueEx(hKey, strValueName, 0, REG_SZ, ByVal strNewFileCommand, Len(strNewFileCommand))
lResult = RegCloseKey(hKey)
End If
' Create
' HKEY_CLASSES_ROOT
' AppID -> FileLabel
lResult = RegCreateKey(HKEY_CLASSES_ROOT, strAppID, hKey)
If strFileType <> "" Then
lResult = RegSetValueEx(hKey, vbNullString, 0, REG_SZ, ByVal strFileType, Len(strFileType))
End If
lResult = RegCloseKey(hKey)
' this block should be a separate routine, to make it easy
' to add multiple commands.
' Create
' HKEY_CLASSES_ROOT
' AppID
' shell
' open
' command -> strOpenCommand
' strKey = strAppID & "\shell\open\command"
' lResult = RegCreateKey(HKEY_CLASSES_ROOT, strKey, hKey)
' lResult = RegSetValueEx(hKey, "", 0, REG_SZ, ByVal strOpenCommand, Len(strOpenCommand))
' lResult = RegCloseKey(hKey)
Me.CreateContextMenuItem "open", strOpenCommand
' Register the default Icon
' Should we make the icon exe,0 by default?
If strIcon <> "" Or strExePath <> "" Then
strKey = strAppID & "\DefaultIcon"
lResult = RegCreateKey(HKEY_CLASSES_ROOT, strKey, hKey)
' If the icon was passed in as a number, assume the
' DefaultIcon is supposed to be "this.exe,1"
' Otherwise, assume the entire file and icon number was used.
Dim strTemp As String
If strIcon = "" Then
strTemp = strExePath ' If no icon was specified, use the default icon from the exe.
ElseIf IsNumeric(strIcon) Then
strTemp = App.Path & "\" & App.EXEName & ".exe," & strIcon
Else
strTemp = strIcon
End If
lResult = RegSetValueEx(hKey, vbNullString, 0, REG_SZ, ByVal strTemp, Len(strTemp))
lResult = RegCloseKey(hKey)
End If
CreateAssociation = 0
End Function
'''''''''''''''''''''''''''''''''''''''''''
' Create a context menu for an existing file association.
' Typical call would be
' .CreateContextMenuItem( "open", "c:\windows\notepad.exe %1"
' .CreateContextMenuItem( "print", "c:\windows\notepad.exe /p %1"
'''''''''''''''''''''''''''''''''''''''''''
Public Sub CreateContextMenuItem(strText As String, strCommand As String)
Dim strKey As String
Dim hKey As Long
Dim lResult As Long
Debug.Assert strAppID <> ""
strKey = strAppID & "\shell\" & strText & "\command"
lResult = RegCreateKey(HKEY_CLASSES_ROOT, strKey, hKey)
lResult = RegSetValueEx(hKey, vbNullString, 0, REG_SZ, ByVal strCommand, Len(strCommand))
lResult = RegCloseKey(hKey)
End Sub
''''''''''''''''''''''''''''''''''''''''''''
' Delete an existing file association
' with minimal error checking
' Note that on NT, this will fail because
' NT does not cascade deletes. You will need to
' query subkeys, and delete them before deleting
' a key.
''''''''''''''''''''''''''''''''''''''''''''
Public Function DeleteAssociation() As Long
If strExt = "" Or strAppID = "" Then
DeleteAssociation = 1
Exit Function
End If
Dim lResult As Long
On Error GoTo DeleteAssociation_EH
lResult = RegDeleteKey(HKEY_CLASSES_ROOT, strExt)
lResult = RegDeleteKey(HKEY_CLASSES_ROOT, strAppID)
DeleteAssociation = 0
Exit Function
DeleteAssociation_EH:
MsgBox "Deleting the keys for " & strExt & " and " & strAppID & " failed. If you are running NT, you will need to delete all child keys before deleting a parent key."
End Function
می خواهم برنامه هایی را با دستورات این سایت یا سایتهای دیگر بسازم.
=======================
یک پروژه می سازیم و یک دکمه روی فرم و کد زیر را داریم:
کد:
Private Sub Command1_Click()
If Dir$("C:/MYFILE.txt") = "" Then
MsgBox "The file was not found. Please try again!"
End If
End Sub
این کد یعنی گشتن به دنبال فایل MYFILE.txt در درایو C .
اگر نباشد مسیج باکس پیغامش را می دهد.
فایده این سوری به گفته سایت اینه که مثلا شما قراره یک دیتابیس را باز کنید. اگه اونجا نباشه برنامه خطا میده ولی با این کد میشه قبلش فهمید که هست یا نه.
=======================
حالا می خواهیم از یک پوشه dir بگیریم. البته فایل های با پسوند txt را.
یک پروژه بسازید و یک دکمه و یک لیست باکس به فرم اضافه کنید و کد زیر:
کد:
Private Sub Command1_Click()
Dim sNextFile As String
sNextFile = Dir$("C:/*.txt")
While sNextFile <> ""
List1.AddItem sNextFile
sNextFile = Dir$
Wend
End Sub
که با زدن دکمه فایلهای مسیر مذکور که txt باشند در لیست باکس لیست می شوند.
===============================
دستور کپی فایل از جایی به جایی:
کد:
'The following line copies a file while changing its name :
FileCopy "C:\TEST.txt", "C:\BACKUP\TEST-BACK.txt"
که با اجرای کد بالا فایل از مسیر اولی با نام جدید در مسیر دومی کپی می شود.
برای جایی هم که فایل اگزه است یعنی کنار فایل اگزه من از خودم دستور زیر را نوشتم:
البته قبلش پروژه را در جایی از هارد ذخیره کردم و فایل اگزه را هم از منوی فایل همان جا ذخیره کردم. یعنی مکان خودم را در هارد مشخص کردم و فایل TEST.txt وقتی آنجا بود کار کپی انجام میشد و اگر نبود خطای زمان اجرا می داد.
New Source Code:
Typing and display text in reverse at real time
Easy Source Code:
Typing and display text in reverse at real time
Yet another tic tac toe program
Copying files from one place to another showing the windows move box
Letting the user click to draw with another line joining them together
Shows the memory available with additional information
Moves the form to the position clicked
Shows whether the user is connected by the internet not using a modual
Shows the amount of space avalible on the system in percentages
Detects which color mode the computer is in eg High color.
Delete a sub directory
This is a simple scribbler!
A better Version of tic tak a toe- Requested about 90 + times finally here
Tic tak a toe
Resizing forms
This is an advanced scroll system
Advanced password system including countdown.
Gradually changing text from blue -> Black
Finding text in a text box
What is in your clipboard text or picture
Deleting files
The program beeps if you go past a line
Formatting numbers so eg before 12345678 now 123,456,678.
Moving a form
A Visual Basic Game which uses random numbers
Loading multi entries from a file
Playing AVI Video's
Hatching
Pop up box after 10 sec's (V.simple)
Dragging files onto form
Store some information to a file
Close another application
Make a program that senses any key presses
Tell the percentage of power in a battery
Make the computer shutdown log off etc
A very simple password checker
Load another application
Harder Source Code:
A complete game of pacman including level editor and other options
More developed alladvantage program has more options and works better.
Simular to the windows based clock. ( Analog )
3D maze game - has amazing graphical display
Makes Alladvantage think you are active and only
3D line drawrings moving
Removes the icon on the toolbar of the form
Replace the text from one letter to another
Scroll though picture boxe using scroll bars
Query excel in to doing a sum
Convert Visual Basic code into HTML code.
Copying files from one place to another showing the windows move box
Letting the user click to draw with another line joining them together
Shows the memory available with additional information
Creates Windows shortcuts
Detects how long windows has been running for
Get the build of your windows and your operating system details.
Is user connected to internet?
Simplified version of VBMail sends email
A Visual Basic FTP Program
Get your current ip address
Any Internet Based Chat System
Virtual Pinball source code
How to browse though dial up connection details or stealing dial up passwords
Space invaders
Rotating some text
This program notes what programs are running
This tells the user what the mouse's status is
Where is your Cd rom drive located?
Quick view of clipart files
Counting down in hour's, min's and second's
Mapping NETWORK drives
Opening the Start bar
Have a calendar for life!
This program watches directories and reports if they have been changed in any way
Make the computer open the cd-rom drive
This makes Windows registry keys!
Time Expired Program
Show an icon on the systray
Show what all the fonts installed on your computer look like!
Make a picture box move with the press of a button
Save images, edit images etc etc a complete utility!
Add some text to a file
Maximize another application
Disable CTRL + ALT + DEL
Move mouse to position
Set Wallpaper of Background
Get current exe loaded on computer.
Colour calculator
An example of a 3d object movement strings
Get Microsoft Word to spell check textboxes
Have a form with a hole in it
Get your windows password username
Tool Bar, Status Bar, Menu bars, Examples
Phone Book
Make a form have no close button
Make a form ONTOP
Hide the task bar
Make a popup application box
Moving the mouse and recording the exact height and width it was clicked on
1000 سورس ویژوال بیسیک....
برای کسانی که سرعت پایین تری دارند دو پوشه از سورسها را کم کردم تا حجم دانلود از 65 مگا به 20 مگا برسد.
و لینکش را در تاپیک (( آموزش مصور ويژوال بيسيك visual basic در مجيد آنلاين )) در پست 222 قرار دادم.
البته به شکل پوشه پوشه هم در ادامه این تاپیک پست می زنم.
دومی ولی جالب بود. دو تا برنامه بود که یکی میشد سرور و یکی کلاینت. ولی قائدتا اول باید برنامه سرور را اجرا کنید تا کلاینت بتونه بهش کانکت بشه.
در کلاینت ip دیفالتی که داخل کادر هست 127.0.0.1 است یعنی به همان کامپیوتری که داخلش برنامه در حال اجرا هست می خواهد وصل بشه.
وقتی هم که کلاینت به سرور با موفقیت وصل میشه در کلاینت نام سرور میاد و در سرور میگه که کلاینت وصل شد.
وقتی هم که می خواهیم برنامه سرور را اجرا کنیم فایروال ویندوز پیغام می دهد که بلوک کنم این برنامه را یا unblock که unblock را بزنید.
پس اول سرور را اجرا کنید بعد کلاینت را . که بعد وصل شدن کلاینت به سرور ..... کلاینت نام سرور را نشان می دهد و سرور می گه کلاینت وصل شد. و 127.0.0.1 هم جلوی آن می آید.
حالا برای تست در دو کامپیوتر یک نفر باید برنامه سرور را در کامپیوترش اجرا کنه و ip خودش را به من بدهد تا من برنامه کلاینت را اجرا کنم.
برنامه سرور به محض اجرا ip کامپیوتر را می دهد.
سلام سالك جان
دستت درد نكنه خوشحالم كه هنوز با قدرت به كارت ادامه ميدي
عزيز تو اين همه مثالي كه داري آيا يه مثال هست كه طريقه كار وي بي با store procedure ها و پارامترهاي ورودي و خروجي رو داشته باشه اگه داشتي ممنون ميشم اينجا بذاري
موفق باشي
با سلام. ممنون از لطفت. من این قسمت را آپلود کردم.
------------------------
این دانلود شامل دو پوشه است. در یکی از پوشه ها یک پروژه داریم با نام SQLGenerator که با موفقیت و بی خطا اجرا شد. به نظرم کوئری ساز است. یعنی با انتخابهایی که شما روی فرم می کنید یک کوئری ساخته می شود.
اولی در پوشه A Systray Icon Example قرار دارد. بی خطا اجرا شد. یک فرم کوچک دارد با یک دکمه. وقتی دکمه را می زنیم فرم پایین می رود ولی نه روی تاسک بار بلکه آیکونی کنار ساعت کامپیوتر قرار می گیرد که با کلیک چپ روی آن یک منو باز می شود برای دو عمل بازیابی و بستن برنامه.
دومی هم بی خطا اجرا شد ولی نفهمیدم چی بود قضیه. باشه برای بعد.
سومی هم بی خطا اجرا شد. محیطی مثل paint بود برای نقاشی.
چهارمی یک ادیتور آیکون است و می توانید با آن آیکونهای مورد علاقه خود را بسازید و save کنید.
پنجمی هم انگار مثل قبلی یک آیکون ادیتور است. فرقش با قبلی را خودتان بررسی کنید.
ششمی هم همین طور.
هفتمی هم با یک سیستم دیگه آیکون ادیتور است.
هشتمی که خودش باز یک فایل زیپ است همان اولی است انگار.
