تکه کد های جالب

[hamed_m]

اگر دوستان موافق باشند در این تاپیک تکه کدهای جالب و بدرد بخور رو قرار بدیم.

پیدا کردن شماره سریال سی پی یو (البته در ایکس پی جواب میده اما هم با اینتل هم با ای ام دی خوب کار میکنه) :



name1=chrtran(SYS(0)," ","")
name1=chrtran(name1,"#","!")
LOCAL lcComputerName, loWMI, lowmiWin32Objects, lowmiWin32Object
lcComputerName = GETWORDNUM(SYS(0),1)
loWMI = GETOBJECT("WinMgmts://" + lcComputerName)
lowmiWin32Objects = loWMI.InstancesOf("Win32_Processor")
FOR EACH lowmiWin32Object IN lowmiWin32Objects
WITH lowmiWin32Object
ProcessorId= TRANSFORM(.ProcessorId)
ENDWITH
ENDFOR

ProcessorId1=""

FOR i=1 TO LEN(ProcessorId)
IF (VAL(SUBSTR(ProcessorId,i,1)))<9 AND (VAL(SUBSTR(ProcessorId,i,1)))>0
ProcessorId1=ProcessorId1+CHR(ASC(SUBSTR(Processor Id,i,1))+0)
ELSE
ProcessorId1=ProcessorId1+CHR(ASC(SUBSTR(Processor Id,i,1))+0)
ENDIF
ENDFOR


مک آدرس دستگاه (اینهم با ایکس پی خوب کار میکنه):



LOCAL gcMacAddress
gcMacAddress = .null.
loloc = CREATEOBJECT("WbemScripting.SWbemLocator")
lowmi = loloc.connectServer()
lomac = lowmi.InstancesOf("Win32_NetworkAdapterConfiguration")
FOR EACH loMacAddr IN lomac
IF loMacAddr.IPEnabled
gcMacAddress = loMacAddr.MACAddress
EXIT
ENDIF
NEXT
STORE .null. to loloc,lowmi,lomac,loMacAddr
? "MAC ADDRESS:" + gcMacAddress

[hamed_m]

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



******************test run******************************************
#Define AtomStrLength 512
public lcAtomName,natom2
lcAtomName = "MYPRG"
Declare Integer GlobalAddAtom In win32api String
Declare Integer GlobalDeleteAtom In win32api Integer
Declare Integer GlobalGetAtomName In kernel32;
INTEGER nAtom,;
STRING @ lpBuffer,;
INTEGER nSize
findAtom(lcAtomName)

Function findAtom(tcAtom)
Create Cursor cs (atom N(12), strlen N(5), Name C(100))
Index On Allt(Name) Tag Name
For nAtom = 49152 To 65535
lpBuffer = Repli(Chr(0), AtomStrLength)
lnResult = GlobalGetAtomName (nAtom, @lpBuffer, AtomStrLength)

If lnResult > 0
Insert Into cs Values (nAtom, lnResult, Left(lpBuffer, lnResult))
Endif
Endfor
Select cs

If Seek(tcAtom)
Messagebox("MYPRG is already running!"+CHR(10)+;
"If you shut the program down illegally please restart windows!","MYPRG",16)
Quit
ELSE
natom2 = GlobalAddAtom(tcAtom)
ENDIF
******************test run******************************************


اینطوری هم موقع خروج حذف کنید:




= GlobalDeleteAtom(natom2)

[hamed_m]

پنجره تون رو به بالاترین سطح بیارید:



Declare Long FindWindow in User32 String, String
Declare BringWindowToTop in User32 Long nhWnd

hWnd = FindWindow(Null, This.Caption)
BringWindowToTop(hWnd)

[kia1349]

خیلی خوبه ادامه بدید

[hamed_m]

ممنون جناب کیا.
اینهم برای خواندن یک صفحه اینترنتی:



lcURL="http://yahoo.com/"
objHTTP = CreateObject("MSXML2.XMLHTTP")
objHTTP.Open("GET", lcURL, .f.)
objHTTP.Send
lcInnerHtml=(objHTTP.ResponseText)
? lcInnerHtml

[hamed_m]

فعال کردن خروج با استفاده از Alt+F4 :
کافیه کد زیر رو به main.prg اضافه کنید:



ON KEY LABEL ALT+F4 Quit

[hamed_m]

پیش آمده که موقع خروج از برنامه به مشکل بر بخورید؟ یه راه حل ساده اما نه چندان استاندارد:



DECLARE ExitProcess IN WIN32API INTEGER
ExitProcess(0)

[hamed_m]

جلوگیری از سفید شدن یا به هم ریختن گرید:



thisform.grid1.RecordSource=""

* kaaretoon ro ba jadvaltoon anjaam bedid

thisform.grid1.RecordSource="jadvaletoon"
thisform.grid1.refresh

[hamed_m]

ارور هندلر:



ON ERROR DO errhand WITH ;
ERROR( ), MESSAGE( ), MESSAGE(1), PROGRAM( ), LINENO(1)



PROCEDURE errhand
PARAMETER merror, mess, mess1, mprog, mlineno
myMessage='Error number: ' + LTRIM(STR(merror))+ CHR(10) ;
+ 'Error message: ' + mess + CHR(10);
+ 'Line: ' + mess1 + CHR(10);
+ 'Line number of error: ' + LTRIM(STR(mlineno)) + CHR(10)
STRTOFILE(myMessage, "c:\myexe\error\"+ALLTRIM(DTOS(DATE()))+".txt",.t.)
ENDPROC

[rezakhj]

لطفا ادامه دهید ما منتظر کدها هستیم .

[mehran_337]

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





************************************************** ********
** Author : Ramani (Subramanian.G)
** FoxAcc Software / Winners Software
** Type : Freeware with reservation to Copyrights
** Warranty : Nothing implied or explicit
************************************************** ********
tCaption1 = "Seasons Greetings .. "
tCaption2 = ".. & Happy New Year - Ramani"
tImage = "G:\picture\new pic\ XP Wallpapers\0002.jpg"
=gsGreet(tCaption1,tCaption2,tImage)
**********************************************


**********************************************
** gsGreet.PRG
** How to run ..
** =gsGreet(tCaption1,tCaption2,tImage)
** You can use your own Bmp or Gif file
** You can also save the picture above as xmas.jpg
** by right click mouse over it and save that
** in the same place as you save this prg.
**********************************************
* Greetings Card form
PROCEDURE gsGreet
PARAMETERS tCaption1, tCaption2, tImage

PUBLIC oform1
oform1=NEWOBJECT("gForm",'','',tCaption1,tCaption2, tImage)
oForm1.TitleBar = 0 && if you wish to have no titlebar
oform1.Show
RETURN
**********************************************
**********************************************
DEFINE CLASS gForm AS form

Height = 454
Width = 633
DoCreate = .T.
BackColor = RGB(0,0,128)
Name = "Greetings"
cSnow = "'"
nSnow = 0
nSnowFont = 20

Add object Text1 as label with ;
AutoSize = .T., ;
BackStyle = 0, ;
FontBold = .T., ;
FontItalic = .T., ;
FontSize = 24, ;
Left = 24, ;
Name = "Text1"

Add object Text2 as label with ;
AutoSize = .T., ;
BackStyle = 0, ;
FontBold = .T., ;
FontItalic = .T., ;
FontSize = 24, ;
Left = 96, ;
Name = "Text2"

PROCEDURE init
LPARAMETERS tCaption1, tCaption2, tGif

IF EMPTY(tCaption2)
tCaption2 = "from Ramani (Subramanian.G)"
ENDIF
IF EMPTY(tCaption1)
tCaption1 = "Greetings !!!"
ENDIF
WITH ThisForm
.Text1.Caption = tCaption1
.Text2.Caption = tCaption2
.Text1.Top = .Height - 72
.Text2.Top = .Height -36
IF !FILE(tGif)
.cSnow = "*"
.nSnowFont = 36
ELSE
.BackColor = RGB(253,254,249)
.ADDOBJECT("Image1","Image")
WITH .Image1
.Picture = tGif
.Stretch = 2
.Width = ThisForm.Width
.Height = ThisForm.Height - 72
.Top = 0
.Left = 0
.Zorder(1)
.Visible = .t.
ENDWITH
ENDIF
**
.nSNow = 50 && Max of t*i
x = 1
FOR t=0 TO 5
FOR I=1 TO 10
cI = ALLTRIM(STR((t*10)+I))
.ADDOBJECT("greet&cI","LABEL")
.greet&cI..AutoSize = .T.
.greet&cI..BackStyle = 0
.greet&cI..FontSize = ThisForm.nSnowFont
.greet&cI..Caption = ThisForm.cSnow
.greet&cI..Left = (i*50) + (10*rand())
.greet&cI..Top = (t*90) + (10*rand())
.greet&cI..Name = "greet&cI"
.greet&cI..ForeColor = RGB(255,255,255)
.greet&cI..Visible = .t.
ENDFOR
ENDFOR
.ADDOBJECT("Timer1","Timer1")
ENDWITH
ENDPROC

PROCEDURE KeyPress
LPARAMETERS nKeyCode, nShiftAltCtrl
IF nKeyCode = 27
ThisForm.Release()
ENDIF
ENDPROC

ENDDEFINE
**********************************************
DEFINE CLASS timer1 AS Timer
Interval = 100
Name = "Timer1"

PROCEDURE Timer
WITH ThisForm
.Text2.forecolor = .Text1.ForeColor
DO CASE
CASE .Text1.forecolor=16711680
.Text1.forecolor=255
CASE .Text1.forecolor=255
.Text1.forecolor=8421376
CASE .Text1.forecolor=8421376
.Text1.forecolor=8388863
OTHERWISE
.Text1.forecolor=16711680
ENDCASE
ENDWITH
**
FOR i= 1 TO ThisForm.nSnow
zm_g='thisform.greet'+alltrim(str(i))
zm_gl=zm_g+'.left'
IF &zm_gl<572
&zm_gl=&zm_gl+10*rand()
ELSE
&zm_gl=1
ENDIF
zm_gl=zm_g+'.top'
IF &zm_gl<392
&zm_gl=&zm_gl+10*rand()
ELSE
&zm_gl=1
ENDIF
ENDFOR
ENDPROC
ENDDEFINE
**********************************************
** EOF
**********************************************

[mehran_337]

این کد هم خیلی به درد می خوره . اول یک پروژه را باز کنید و بعد این کد رو اجرا کنید . تمام جداول را باز می کنه و ساختارشونو در یک فایل در اختیارتون قرار می ده . به نظر من یکی از فایده هاش می تونه در بازسازی فایل های ایندکس باشه . من در برنامه هام نیاز به این دارم که cdx ها دوباره ساخته بشه مجبورم ساختار همه جداولمو دستی دربیارم.
اما با این کد ....



************************************************** ********
** Author : Ramani (Subramanian.G)
** FoxAcc Software / Winners Software
** Type : Freeware with reservation to Copyrights
** Warranty : Nothing implied or explicit
** Last modified : 15 December, 2002
************************************************** ********
** How to use .... (Example)
** 1. Copy the gs_TableS.PRG routine as given below
** 2. Open up your project in your project manager
** 3. Run the programme from Command window by typing
** DO gs_TableS
** 4. All the open projects Tables are involved
** SO if you want for one project..
** .... only keep that project open.
************************************************** ********
** PROCEDURE gs_Tables
**
IF Application.Projects.Count()=0
=MESSAGEBOX("No Project Open.Exiting... ", ;
0+16,"No Active Project Available")
RETURN
ENDIF
CLOSE TABLES ALL
myFile=PUTFILE("Select a file name for the Table Structure","c:\my documents","txt")
IF EMPTY(myFile)
RETURN
ENDIF
myFile = ALLTRIM(myFile)
IF ATC(".",myFile) > 0
myFile = LEFT(myFile,ATC(".",myFile)-1)+".txt"
ELSE
myFile = myFile+".txt"
ENDIF
ERASE (myFile)
**
LOCAL cTable, i, p
FOR p = 1 TO application.Projects.Count
FOR i = 1 TO application.Projects(p).Files.Count
cTable = application.Projects(p).Files(i).NAME
IF UPPER(JUSTEXT(cTable)) = "DBC"
OPEN DATABASE (cTable)
DISPLAY TABLES TO (myFile) ADDITIVE NOCONSOLE
SELECT objectName FROM (cTable) ;
WHERE UPPER(objectType)="TABLE" ;
INTO CURSOR myCursor
SCAN
** WAIT WINDOW objectName && if you want
SELECT 0
USE (myCursor.objectName)
DISPLAY STRUCTURE TO (myFile) ADDITIVE NOCONSOLE
USE
SELECT myCursor
ENDSCAN
USE IN myCursor
ENDIF
IF UPPER(JUSTEXT(cTable)) = "DBF"
** WAIT WINDOW cTable && if you want wait status
USE (cTable)
DISPLAY STRUCTURE TO (myFile) ADDITIVE NOCONSOLE
USE
ENDIF
ENDFOR
ENDFOR
CLOSE TABLES ALL
MODIFY FILE (myFile)
RETURN
************************************************** ********
** EOF
************************************************** ********

[mehran_337]

چاپ تصویر


LPARAMETERS tcImage
*tcImage = GETPICT()
*--------------------------------------------------------
* VFP code that shows how to print image files.
* Code adapted from Microsoft Knowledge Base article
* 895602. http://support.microsoft.com/kb/895602/EN-US/
*
* Most of the codes and comments below come from
* Trevor Hancock, from MS
*--------------------------------------------------------
LOCAL lnArea
lnArea = SELECT()
CREATE CURSOR ReportTemp (ImageFile c(150))
INSERT INTO ReportTemp VALUES (tcImage)
*-- This calls a function that makes a report programmatically.
*-- This is included here just to make sure that this sample can be run
*-- as-is, without asking the developer to manually create a report.
MakeReport()
*-- Make sure that the cursor is selected,
*-- and then run the report to preview using
*-- the instance of our Report Listener.
SELECT ReportTemp
REPORT FORM ___ImageReport PREVIEW
DELETE FILE "___ImageReport.fr*"
SELECT (lnArea)
RETURN
*--------------------------------
*-- This function programmatically creates a report
*-- with an OLE Bound control and other fields. This is included
*-- only for demonstration purposes so this article code can stand-alone.
*-- Typically, you would create your own report manually by using
*-- the report designer.
FUNCTION MakeReport
CREATE REPORT ___ImageReport FROM ReportTemp
*-- Open the report file (FRX) as a table.
USE ___ImageReport.FRX IN 0 ALIAS TheReport EXCLUSIVE
SELECT TheReport
*-- Remove from the FRX the auto generated fields and labels
DELETE FROM TheReport WHERE ObjType = 5 AND ObjCode = 0 && Remove the Labels
DELETE FROM TheReport WHERE ObjType = 8 AND ObjCode = 0 && Remove the Fields

*-- Add a Picture/OLE Bound control to the report by inserting a
*-- record with appropriate values. Using an object that is based on the EMPTY
*-- class here and the GATHER NAME class later to insert the record makes it easier to
*-- see which values line up to which fields (when compared to a large
*-- SQL-INSERT command).
LOCAL loNewRecObj AS EMPTY
loNewRecObj = NEWOBJECT( 'EMPTY' )
ADDPROPERTY( loNewRecObj, 'PLATFORM', 'WINDOWS' )
ADDPROPERTY( loNewRecObj, 'Uniqueid', SYS(2015) )
ADDPROPERTY( loNewRecObj, 'ObjType', 17 ) && "Picture/OLE Bound Control"
ADDPROPERTY( loNewRecObj, 'NAME', 'ReportTemp.ImageFile' ) && The object ref to the IMAGE object.
ADDPROPERTY( loNewRecObj, 'Hpos', 100)
ADDPROPERTY( loNewRecObj, 'Vpos', 600)
ADDPROPERTY( loNewRecObj, 'HEIGHT', 100000)
ADDPROPERTY( loNewRecObj, 'WIDTH', 100000)
ADDPROPERTY( loNewRecObj, 'DOUBLE', .T. ) && Picture is centered in the "Picture/OLE Bound Control"
ADDPROPERTY( loNewRecObj, 'Supalways', .T. )
*-- For the Picture/OLE Bound control, the contents of the OFFSET field specify whether
*-- Filename (0), General field name (1), or Expression (2) is the source.
ADDPROPERTY( loNewRecObj, 'Offset', 2 )
*-- Add the Picture/OLE Bound control record to the report.
APPEND BLANK IN TheReport
GATHER NAME loNewRecObj MEMO
*-- Clean up and then close the report table.
PACK MEMO
USE IN SELECT( 'TheReport' )
ENDFUNC

[mehran_337]

این کد مشخصات تصویر را بر می گرداند






LOCAL lcSource, lcInfo, lnWidth, lnHeight, lnHorRes, lnVerRes, lnPixForm
lcSource = GETPICT()

LOCAL loImage AS GpImage OF ffc/_gdiplus.vcx
loImage = NEWOBJECT("GpImage", HOME() + "ffc/_gdiplus.vcx")
loImage.CreateFromFile(lcSource)

lnWidth = loImage.ImageWidth
lnHeight = loImage.ImageHeight
lnHorRes = loImage.HorizontalResolution
lnVerRes = loImage.VerticalResolution
lnPixForm = loImage.PixelFormat
lcPixForm = GetPixFormatName(lnPixForm)

lcInfo = "Image : " + lcSource + CHR(13) + CHR(13) +;
"Width : " + TRANSFORM(lnWidth) + " pixels" + CHR(13) +;
"Height : " + TRANSFORM(lnWidth) + " pixels" + CHR(13) +;
"Pixel Format : " + lcPixForm + CHR(13) +;
"Hor. Resol : " + TRANSFORM(lnHorRes) + " pixels/inch" + CHR(13) +;
"Ver. Resol : " + TRANSFORM(lnVerRes) + " pixels/inch" + CHR(13)

MESSAGEBOX(lcInfo, 64, "Image Information")
RETURN

PROCEDURE GetPixFormatName(nPix)
DO CASE
CASE nPix = 0x00030101
RETURN "1bppIndexed"
CASE nPix = 0x00030402
RETURN "4bppIndexed"
CASE nPix = 0x00030803
RETURN "8bppIndexed"
CASE nPix = 0x00101004
RETURN "16bppGrayScale"
CASE nPix = 0x00021005
RETURN "16bppRGB555"
CASE nPix = 0x00021006
RETURN "16bppRGB565"
CASE nPix = 0x00061007
RETURN "16bppARGB1555"
CASE nPix = 0x00021808
RETURN "24bppRGB"
CASE nPix = 0x00022009
RETURN "32bppRGB"
CASE nPix = 0x0026200A
RETURN "32bppARGB"
CASE nPix = 0x000E200B
RETURN "32bppPARGB"
CASE nPix = 0x0010300C
RETURN "48bppRGB"
CASE nPix = 0x001C400E
RETURN "64bppPARGB"
OTHERWISE
RETURN "Unidentified"
ENDCASE
ENDPROC

[mehran_337]

این هم یک گرید با سطر های رنگی



Public oForm
oForm = Newobject("form1")
oForm.Show
Return
************************************************** ********
* class definition for form1
Define Class form1 As Form
Top = 0
Left = 0
Height = 340
Width = 381
DoCreate = .T.
Caption = "Grid Highlight"
Name = "form1"
ShowTips = .T.
Procedure Init
Public gvTypeA,gvTypeD,gvTypeR
gvTypeA = Rgb(255,0,0)
gvTypeD = Rgb(0,0,128)
gvTypeR = Rgb(64,128,128)
Select temp
Locate
This.AddObject('grid1','grid1')
This.grid1.Visible = .T.
Endproc
Procedure Load
* create cursor for temporary data
Create Cursor temp (cType c(1),cDesc c(40),nRand i)
lnFlds = Afields(laFlds,'temp')
For lnY = 1 To lnFlds
lcNdxNm = laFlds(lnY,1)
Index On &lcNdxNm Tag &lcNdxNm
Next
* create index for all fields
For lnX = 1 To 9
m.cType = 'R'
m.cDesc = m.cType + Space(2) + 'Description ' + Alltrim(Str(lnX))
m.nRand = Rand() * 100
Insert Into temp From Memvar
Next
For lnX = 1 To 9
m.cType = 'A'
m.cDesc = 'Description ' + m.cType + Space(2) + Alltrim(Str(lnX))
m.nRand = Rand() * 100
Insert Into temp From Memvar
Next
For lnX = 1 To 9
m.cType = 'D'
m.cDesc = Alltrim(Str(lnX)) + Space(2) + m.cType + Space(2) + 'Description'
m.nRand = Rand() * 100
Insert Into temp From Memvar
Next
Endproc
Procedure Unload
Release gvTypeA,gvTypeD,gvTypeR
Endproc
Enddefine
* end class definition for form1
************************************************** ********
* class definition for grid
Define Class grid1 As Grid
ColumnCount = 3
FontSize = 8
DeleteMark = .F.
Height = 313
Left = 13
Panel = 1
RowHeight = 17
Top = 12
Width = 354
Name = "Grid1"
GridLines = 0
Procedure Init
With This
lcForeColor = "Iif(cType='R',gvTypeR,Iif(cType='D',gvTypeD,gvType A))"
.RecordSource = 'temp'
.HighlightStyle = 2
.SetAll('DynamicForeColor',lcForeColor,'column')
.HighlightBackColor = Evaluate(.Column1.DynamicForeColor)
.HighlightForeColor = Rgb(255,255,255)
.SetAll('SelectedBackColor',.HighlightBackColor ,'textbox')
.SetAll('SelectedForeColor',.HighlightForeColor ,'textbox')
With .Column1
.ControlSource = 'cType'
.FontSize = 8
.Width = 36
.RemoveObject('header1')
.AddObject('header1','header1')
.header1.Caption = "Type"
Endwith
With .Column2
.ControlSource = 'cDesc'
.FontSize = 8
.Width = 206
.RemoveObject('header1')
.AddObject('header1','header1')
.header1.Caption = "Description"
Endwith
With .Column3
.ControlSource = 'nRand'
.FontSize = 8
.Width = 75
.RemoveObject('header1')
.AddObject('header1','header1')
.header1.Caption = "Number"
Endwith
.Refresh
Endwith
Endproc
Procedure AfterRowColChange
Lparameters nColIndex
With This
.HighlightBackColor = Evaluate(.Column1.DynamicForeColor)
.HighlightForeColor = Rgb(255,255,255) && white
.SetAll('SelectedBackColor',.HighlightBackColor ,'textbox')
.SetAll('SelectedForeColor',.HighlightForeColor ,'textbox')
Endwith
Endproc
Enddefine
* end class definition for grid
************************************************** ********
* class definition for Header
Define Class header1 As Header
Tag = 'A'
FontSize = 8
ToolTipText = 'Click here to sort'
Procedure Click
Local lcNdx,lcOrder,lcAlias
With This
If .Tag = 'A'
lcOrder = 'Ascending'
.Tag = 'D'
Else
lcOrder = 'Descending'
.Tag = 'A'
Endif
lcNdx = .Parent.ControlSource
lcAlias = .Parent.Parent.RecordSource
Select (lcAlias)
Set Order To &lcNdx &lcOrder
.Parent.Parent.Refresh
Endwith
Endproc
Enddefine
* end class definition for Header

[mehran_337]

این کد تمام چاپگر ها تعریف شده در سیستم را به همراه پورت هر یک چاپ می کند


LOCAL wshNetwork As "WScript.Network" &&WshNetwork
LOCAL Printers As Object &&WshCollection
LOCAL i As Integer

wshNetwork = CreateObject("WScript.Network")
Printers = wshNetwork.EnumPrinterConnections

For i = 1 To Printers.Count - 1 Step 2
? "Printer Name: "
?? Printers.Item(i)
? "Port: "
?? Printers.Item(i - 1)
Endfor

? "Total of Installed Printers: "
?? INT(Printers.Count / 2)

Printers = .null.
wshNetwork = .null.

[hamed_m]

ممنون مهران عزیز. کدهای بسیار جالبی بودند. امید که من هم بتونم با کد خدمت برسم.

[mehran_337]

خواهش می کنم .
این بنای خوب و خودت پایه ریزی کردی . البته کدهای شما بیشتر در زمینه کار با توابع ویندوز بود که برای من هم خیلی جالب بود و هم اینکه جایی ندیده بودم چون همیشه فکر می کردم فاکس پرو با توابه ویندوزی مشکل داره . اما به لطف دوستان خوبی مثل شما ها دیدم عوض شد . به هر حال این تاپیک مورد علاقه من هست . پس ولش نکن . من هم تا حد امکان کمک می کنم
موفق باشی

[kia1349]

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

[mehran_337]

آقا رضا ! این هم از اون حرفهاستا
شما که همه اینها رو موقعی کار می کردید که ما داشتیم reset کردن و یاد می گرفتیم.
جوابهای شما باعث دلگرمی ماست . خیلی خوشحال می شم وقتی میام و می بینم جواب می دین یه جورایی آدم برای مطلب گذاری مشتاق تر می شه.

[reza1357]

با سپاس و درود بی کران بر شما مهران جان
کدهای بسیار جالبی بودند. دستت درد نکنه.

[hamed_m]

نام کامپیوتر:



DECLARE INTEGER GetComputerName ;
IN WIN32API ;
STRING@ cComputerName,;
INTEGER@ nSize

lcComputer=SPACE(80)
lnSize=80

=GetComputername(@lcComputer,@lnSize)
IF lnSize < 2
lcComputer=""
ENDIF

? lcComputer

[mehran_337]

نام تابع را همراه مسیر بدهید اگر آن مسیر وجود داشته باشد مقدار true را بر می گرداند


*
* IsDir( <cDirectory> ) -> boolean
*
* Return TRUE if exist directory <cDirectory>
*
FUNCTION isDIR( cDir )
LOCAL olderror, oldPath, lOk

IF NOT EMPTY(cDir)
lOk = .T.
olderror = ON('ERROR')
oldPath = SYS(5)+CURDIR()
ON ERROR lOk = .F.
SET DEFAULT TO (cDir)
ON ERROR &olderror
SET DEFAULT TO (oldPath)
ELSE
lOk = .F.
ENDIF

RETURN lOk

ENDFUNC

[mehran_337]

این کد شاید واسه خیلی ها جالب باشه . تمام مشخصات چاپگرهای موجود حتی در شبکه رو نمایش می ده


LOCAL wshNetwork As "WScript.Network" &&WshNetwork
LOCAL Printers As Object &&WshCollection
LOCAL i As Integer

wshNetwork = CreateObject("WScript.Network")
Printers = wshNetwork.EnumPrinterConnections

For i = 1 To Printers.Count - 1 Step 2
? "Printer Name: "
?? Printers.Item(i)
? "Port: "
?? Printers.Item(i - 1)
Endfor

? "Total of Installed Printers: "
?? INT(Printers.Count / 2)

Printers = .null.
wshNetwork = .null.

[mehran_337]

توی این سایت وقتی صحبت از نحوه استفاده از بانک می شد به این نتیجه رسیدیم که یکسری از دستورات رو باید ابتدای هر برنامه بعنوان " آماده سازی برنامه ... " اجرا کنیم یکی از این دستورات pack برای تمام بانکهاست . شاید نوشتن نام تمام بانک ها کار مشکلی باشد و اینکه بعدا بانکی را اضافه کنیم یادمان برود . این کد تمام بانکهای موجود در شاخه مورد نظر را pack می کند
فقط کافیه مسیر بدهیم خودش تمام جداول را پیدا می کند


PARAMETERS myDataDir
SET EXCLUSIVE ON
LOCAL aFiles, nCount, I
DIMENSION aFiles(1,1)
nCount = ADIR(aFiles,mydataDir+"\"+"*.DBF")
=ASORT(aFiles,1)
I=1
FOR I = 1 TO nCount
WAIT WINDOW "Reindexing "+aFiles(I,1)+ ;
" ... Please wait" NOWAIT
SELECT 0
USE mydataDir+"\"+(aFiles(I,1))
PACK
USE
WAIT CLEAR
ENDFOR
SET EXCLUSIVE OFF
RETURN

[rezamim]

توی این سایت وقتی صحبت از نحوه استفاده از بانک می شد به این نتیجه رسیدیم که یکسری از دستورات رو باید ابتدای هر برنامه بعنوان " آماده سازی برنامه ... " اجرا کنیم یکی از این دستورات pack برای تمام بانکهاست . شاید نوشتن نام تمام بانک ها کار مشکلی باشد و اینکه بعدا بانکی را اضافه کنیم یادمان برود . این کد تمام بانکهای موجود در شاخه مورد نظر را pack می کند
فقط کافیه مسیر بدهیم خودش تمام جداول را پیدا می کند


PARAMETERS myDataDir
SET EXCLUSIVE ON
LOCAL aFiles, nCount, I
DIMENSION aFiles(1,1)
nCount = ADIR(aFiles,mydataDir+"\"+"*.DBF")
=ASORT(aFiles,1)
I=1
FOR I = 1 TO nCount
WAIT WINDOW "Reindexing "+aFiles(I,1)+ ;
" ... Please wait" NOWAIT
SELECT 0
USE mydataDir+"\"+(aFiles(I,1))
PACK
USE
WAIT CLEAR
ENDFOR
SET EXCLUSIVE OFF
RETURN



و اگر برنامه تحت شبکه باشه ؟!:متفکر:

[hamed_m]

آقا رضا اصولا وقتی برنامه تحت شبکه باشه استفاده EXCLUSIVE از تیبل ها بسیار مشکل سازه. در واقع باید اکسس تمام یوزرها رو قطع کنید. ممکن هست اما خیلی جالب نیست. شاید استفاده از یه دیتابیس اینجین راه بسیار مناسب تری باشه.



باز کردن یک صفحه اینترنتی با استفاده از بروزر پیش فرض:



LPARAMETERS pcURL
LOCAL lnRes
lnRes = ShellExec(pcURL,'','OPEN','') && GTv10.00 wgcs
if lnRes <= 32 && v10.00 wgcs
=MessageBox('Error number '+alltrim(str(lnRes))+' while opening '+crlf;
+ pcURL, mbxOk, 'Failed') && v10.00 wgcs
endif


FUNCTION ShellExec
LPARAMETERS lcFileName, lcWorkDir, lcOperation, pcParameters
LOCAL pp, lcParam
pp = pCount() && LAS v9b1w wgcs
if pp>3 && LAS v9b1w wgcs
lcParam = pcParameters && LAS v9b1w wgcs
else && LAS v9b1w wgcs
lcParam = ''
endif
lcWorkDir=IIF(type("lcWorkDir")="C",lcWorkDir,"")
lcOperation=IIF(type("lcOperation")="C",lcOperation,"Open")
DECLARE INTEGER ShellExecute ;
IN SHELL32.DLL ;
INTEGER nWinHandle,;
STRING cOperation,;
STRING cFileName,;
STRING cParameters,;
STRING cDirectory,;
INTEGER nShowWindow
RETURN ShellExecute(0,lcOperation,lcFilename,lcParam,lcWo rkDir,1)

[rezamim]

آقا رضا اصولا وقتی برنامه تحت شبکه باشه استفاده EXCLUSIVE از تیبل ها بسیار مشکل سازه. در واقع باید اکسس تمام یوزرها رو قطع کنید. ممکن هست اما خیلی جالب نیست. شاید استفاده از یه دیتابیس اینجین راه بسیار مناسب تری باشه.



راهی که من استفاده میکنم اینه
1 - چک میکنم که بانکها قابل باز شدن بصورت انحصاری هستند یا نه . اگه نه پس بیخیال
2 - اگه میشه پس سریع همه رو بصورت انحصاری باز میکنم و pack و reindex . اگه در این زمان کاربری بخواهد وارد شود پیغام میدم که بانکها دارند بازسازی میشوند ، مجددا وارد شوید .
تا حالا هم عالی جواب گرفتم

[mehran_337]

با سلام به همه :
اول اینکه بازهم چندروز از دیدن این سایت محروم بودم نمی دونم چه اتفاقی داره میفته . اما امید وارم مشکل اساسی نباشه.اگه کسی می دونه بهم بگه که چرا این مدت همش سایت مشکل داره.
آقای حیدری کیا ! دیدن پیام تشکر شما باعث شرمندگی من می شه . چون ما و همه اعضای سایت متشکر از شما و زحمات شما هستیم ایکاش وقت اجازه می داد و با جان و دل راه شما را ادامه می دادیم.
آقای رضا میم ! ما قابل تعارف شما نیستیم اما متاسفانه اطلاعات من در شبکه زیر صفره امیدوارم با کمک دوستان با صفایی مثل شما بنده را یاری کنید تا کمی مطالب شبکه ای یاد بگیرم.
و حامد عزیز که از سرزمینی دیگر عرق وطن دوستی اش یاری کننده هموطنان ایرانی اش می باشد بانی خیر این موضوع می باشند و تا حالا پشتیبان و معلم من در زمینه تکه کدهای واقعا جالب ایشان می باشد.
انشاءالله همچنان به زکات علم خود بپردازیم

[rezaTavak]

راهی که من استفاده میکنم اینه
1 - چک میکنم که بانکها قابل باز شدن بصورت انحصاری هستند یا نه . اگه نه پس بیخیال
2 - اگه میشه پس سریع همه رو بصورت انحصاری باز میکنم و pack و reindex . اگه در این زمان کاربری بخواهد وارد شود پیغام میدم که بانکها دارند بازسازی میشوند ، مجددا وارد شوید .
تا حالا هم عالی جواب گرفتم

چطوری چک میکنید؟

[hamed_m]

البته میشه عملیات یوزرها رو هم متوقف کرد:
1- یه تایمر در برنامه اجرایی وجود فایلی روی سرور رو بررسی میکنه.
2- اگر وجود نداشت برنامه بصورت عادی کارش رو میکنه.
3- اگر وجود داشت از یوزر درخواست ذخیره تغییرات رو میکنه و بعد تیبلهای مورد استفاده اش رو میبنده.
4- یه تایمر دیگه چک میکنه که تیبلها مورد استفاده هستند یا نه. اگر نه کار پک انجام میشه و اون فایل روی سرور پاک میشه.
5- به همه اجازه اجرای برنامه اصلی داده میشه.
کمی مشکله پیاده سازیش. اما ممکنه.


طریقه چک کردن اینکه جدول قابلیت باز شدن EXCLUSIVE داره یا نه:



USE '\\server\data\yourtable.dbf'
lcstatus=SYS(2011)
llretwert=IIF(UPPER(lcstatus)="EXCLUSIVE",.T.,.F.)

IF (llretwert==.F.)
* kasi dar hale estefadeh az jadvaleh

ELSE
* jadval EXCLUSIVE dar ekhtiare shomast
* baghieh code pack

ENDIF


خاطرتون نره که ارورها رو هندل کنید:



ON ERROR do excl_error


FUNCTION excl_error
RETURN
*EOF excl_error


وگرنه جالب نمیشه. و بعد هم ارور هندلر رو دوباره ست کنید. امیدوارم مورد استفاده قرار بگیره.





پ ن - مهران عزیز چوبکاری نفرمایید. ممنون از لطفتون.

[rezamim]

چطوری چک میکنید؟

اگر برنامه دفترچه تلفن رو دیده باشید ، در اول برنامه یکسری کارهایی رو انجام میده مثل :
1 - چک کردن وجود بانکها
2 - چک کردن وجود ایندکسها
3 - چک کردن باز شدن سالم بانکها همراه با ایندکسها
و . . .

در همین مرحله یکی از کارها توسط این تابع هست


FUNCTION CanOpenExclusive
********************************************
RtrnCanOpen = .T.
ErrorCommand = ON( 'ERROR' )
ON ERROR STORE .F. TO RtrnCanOpen
FOR Count = 1 TO NoOfDbfs
USE DbfsPath + IIF( Count > RootDbfs,ActiveDbfYear,'')+ AliasName(Count) + '.DAT' EXCLUSIVE
IF RtrnCanOpen = .F.
EXIT
ENDIF
ENDFOR
CLOSE DATABASES
ON ERROR &ErrorCommand
RETURN( RtrnCanOpen )

[mehran_337]

سلام
حالا که این بحث پیش اومد من یه سوالی دارم
دستور pack توی شبکه چطور باید استفاده کرد.
وسوال دوم اینکه وقتی از delete استفاده میشه و هنوز پک نکردیم بازهم دستورتی مانند RECCOUNT , COUNT و امثال اینها عدد درستی را نمی دهند چون با دکوردهای DEL شده محاسبه می کنند البته من قبل از هر DELET دستور BLANK می کنم و بجای RECCOUN از دستور <نام فیلد>COUNT FOR !EMPT استفاده می کنم که زیاد برایم جالب نیست. اگه می شه راهنماییم کنید

[mehran_337]

این کد لیست تمام شاخه ها و زیر شاخه ها را در یک جدول ذخیره می کند.


************************************************** *******
** Author : Ramani (Subramanian.G)
** FoxAcc Software / Winners Software
** ramani_vfp@yahoo.com
** Type : Freeware with reservation to Copyrights
** Warranty : Nothing implied or explicit
** Last modified : 31 January, 2003
************************************************** *******
** The following uses Filer.DLL and
** extracts all files in a directory as a cursor.
** How to run : Save this as dir2Cursor.prg
** =dir2Cursor(cDir)
************************************************** *******
** FUNCTION dir2cursor
PARAMETERS pDir
IF PARAMETERS() < 1 OR EMPTY(pDir)
RETURN
ENDIF
pDir = ADDBS(ALLTR(pDir))
CREATE CURSOR filename (cfilename c(128))
omyfiler = CREATEOBJECT('Filer.FileUtil')
omyfiler.searchpath = pDir && Search Directory
omyfiler.subfolder = 1 && 1=add all subdirectories else 0
oMyFiler.SortBy = 0
omyfiler.FIND(0)
LOCAL ncount
ncount = 1
FOR nfilecount = 1 TO omyfiler.FILES.COUNT
IF omyfiler.FILES.ITEM(nfilecount).NAME = "." OR ;
omyfiler.FILES.ITEM(nfilecount).NAME = ".."
LOOP
ENDIF
APPEND BLANK
REPLACE cfilename ;
WITH UPPER(omyfiler.FILES.ITEM(nfilecount).PATH)+ ;
UPPER(omyfiler.FILES.ITEM(nfilecount).NAME)
ENDFOR
BROW
************************************************** *******
* EOF

[hamed_m]

مهران عزیز،
با set deleted on هم همین نتایج رو میگیرید؟

[hamed_m]

ورژن ویندوز:

http://fox.wikis.com/wc.dll?Wiki~GetWindowsVersion~VFP

[mehran_337]

آره حامد جان!
مشکل من همینه که وقتی set delete on هم هست تعداد رکورد و بعضی از توابع را با رکوردهای حذف شده محاسبه می کنه اگه میشه راهنماییم کنین

[hamed_m]

count for !deleted() to notdeleted

? notdeleted

[mehran_337]

این کد اختلاف زمان بین دو ساعت را بر می گرداند:


FUNCTION TimeDif
PARAMETERS tDateTime1, tDateTime2

LOCAL lReturn, myHours, myMinutes, mySeconds
lReturn = .t.

IF PARAMETERS() # 2
lReturn = .f.
ENDIF
IF ! VARTYPE(tDateTime1) = "T"
lReturn = .f.
ENDIF
IF ! VARTYPE(tDateTime2) = "T"
lReturn = .f.
ENDIF
IF lReturn
IF tDateTime2 > tDateTime1
mySeconds = tdateTime2 - tDateTime1
ELSE
mySeconds = tdateTime1 - tDateTime2
ENDIF
mySeconds=INT(mySeconds)
cTime = TRANSFORM(INT(mySeconds/3600),"9999")+":"+ ;
TRANSFORM(MOD(INT(mySeconds/60),60),"99")+":"+ ;
TRANSFORM(MOD(mySeconds,60),"99")
WAIT WINDOW "Time Difference = "+cTime
RETURN cTime
ELSE
=MESSAGEBOX("Pass to this function ;
From DateTime and To DateTime", ;
0+16,"Wrong Parameters")
RETURN lReturn
ENDIF

[mehran_337]

کلاس adir


************************************************** ***********************
* FileProps class definition
************************************************** ***********************
Define Class FileProps As Custom
cName = Space(0)
nSize = 0
dDate = {}
cTime = Space(0)
cFlags = Space(0)

dtDateTime = {}
nHour = 0
nMin = 0
nSec = 0

lArchive = .F.
lHidden = .F.
lReadOnly = .F.
lSystem = .F.
lDir = .F.

Procedure Init
Lparameters tcFile, tcFlags
if ! vartype(m.tcFile)=="C" or EMpty(m.tcFile)
tcFile = "*.*"
endif
if ! vartype(m.tcFlags)=="C"
tcFlags = "HS"
endif
Return this.GetFileProps(m.tcFile, m.tcFlags)
EndProc


Function GetFileProps(tcFile, tcFlags)
Release aFile
Dimension aFile[1]
=ADir(afile, m.tcFile, m.tcFlags) &&1=Name(c), 2=Size(n), 3=Date(d), 4=Time(c), 5=Attr(c)

If vartype(afile[1]) <> 'C'
=MessageBox("Could not locate file: " + cFile,48,"FileProps Error")
Return .F.
Endif

this.cName = afile[1]
this.nSize = afile[2]
this.dDate = afile[3]
this.cTime = afile[4]
this.cFlags = afile[5]

this.dtDateTime = Ctot(Dtoc(this.dDate)+this.cTime)
this.nHour = Hour(this.dtDateTime)
this.nMin = Minute(this.dtDateTime)
this.nSec = Sec(this.dtDateTime)

this.lArchive = "A" $ this.cFlags
this.lHidden = "H" $ this.cFlags
this.lReadOnly = "R" $ this.cFlags
this.lSystem = "S" $ this.cFlags
this.lDir = "D" $ this.cFlags
EndFunc
EndDefine



************************************************** ******************************
*** Sample Code
************************************************** ******************************
Local oMyFile as Object, cMyFile as String
oMyFile = .NULL.
cMyFile = Home() + "vfp" + Left(Transform(Version(5)),1) + ".exe"
Clear

oMyFile = CreateObject("FileProps", cMyFile)

If Type('oMyFile') = 'O' and !IsNull(oMyFile)
? "Name: " + oMyFile.cName
? "Size: " + Transform(oMyFile.nSize)
? "Date: " + Transform(oMyFile.dDate)
? "cTime: " + oMyFile.cTime
? "cFlags: " + oMyFile.cFlags
? "DT: " + Transform(oMyFile.dtDateTime)
? "Hour: " + Transform(oMyFile.nHour)
? "Min: " + Transform(oMyFile.nMin)
? "Sec: " + Transform(oMyFile.nSec)
? "Arch?: " + Transform(oMyFile.lArchive)
? "Hidden?:" + Transform(oMyFile.lHidden)
? "RO?: " + Transform(oMyFile.lReadOnly)
? "System?:" + Transform(oMyFile.lSystem)
? "Dir?: " + Transform(oMyFile.lDir)
Else
? "Error Getting File Props"
Endif
Return

[mehran_337]

این کد تمام فونتهای موجود در سیستم را لیست می کند :


AFONT(laFont)
lnCuenta=ALEN(laFont)
DEFINE POPUP Fonts
FOR INDEX = 1 TO lnCuenta
DEFINE BAR INDEX OF Fonts PROMPT ALLTRIM(laFont(INDEX)) FONT ALLTRIM(laFont(INDEX))
ENDFOR
ACTIVATE POPUP Fonts

[hamed_m]

ممنون مهران گرامی که کلی کد جالب گذاشتید.

اینهم یه متد جالب برای اینکه فقط یکبار اجازه اجرای برنامه تون رو بدید:



LOCAL llQuit
oManager = GETOBJECT([winmgmts:])
cQuery = [select * from win32_process where name='myapp.exe']
oResult = oManager.ExecQuery(cQuery)

IF oResult.Count > 1
llQuit = .T.
ENDI
oManager = .NULL.
oResult = .NULL.
RELEASE cQuery, oResult, oManager

IF llQuit
QUIT
ENDI

[hamed_m]

اینهم برای ترمینیت فایلهای اجرایی (البته در ورژنهای پایین فاکس و ویندوز کار نمیکنه):



oManager = GETOBJECT([winmgmts:])
cQuery = [select * from win32_process where name='exe2kill.exe']
oResult = oManager.ExecQuery(cQuery)
FOR EACH oProcess IN oResult
oProcess.Terminate(0)
NEXT
oManager = .NULL.
oResult = .NULL.

[hamed_m]

دوتا مقدار جالب:
_VFP.StartMode
0 زمان اجرا در محیط فاکس
4 زمان اجرای برنامه کاربردی
VERSION(2)
1 یا 2 زمان اجرا در محیط فاکس
0 زمان اجرای برنامه کاربردی

[hamed_m]

یونیکد و فاکس:
http://www.west-wind.com/presentations/foxunicode/foxunicode.asp

[mehran_337]

حامد جان ! مثل همیشه عالی بود
فقط ببخشیدا ... اییییی ترمینیت که گفتی یعنی چه

[hamed_m]

ممنون از لطفتون مهران عزیز.
اینهم کمی در مورد ترمینیت:
http://www.urbandictionary.com/define.php?term=Terminated
سری فیلمهای ترمیناتور رو که دیدید :) .

[hamed_m]

کپی به Clipboard با GDI+:

http://www.news2news.com/vfp/?example=457

[mehran_337]

ممنونم ولی با عرض معذرت چیزی دستگیرم نشد

[hamed_m]

توقف اجرا. خروج اجباری. شاید ترمینیت رو به نابود کردن بشه ترجمه کرد در این مورد.

[mehran_337]

حامد ممنون.
--------------------
حامد عزیز ممنون. جالب بود

[rahro]

البته میشه عملیات یوزرها رو هم متوقف کرد:
1- یه تایمر در برنامه اجرایی وجود فایلی روی سرور رو بررسی میکنه.
2- اگر وجود نداشت برنامه بصورت عادی کارش رو میکنه.
3- اگر وجود داشت از یوزر درخواست ذخیره تغییرات رو میکنه و بعد تیبلهای مورد استفاده اش رو میبنده.
4- یه تایمر دیگه چک میکنه که تیبلها مورد استفاده هستند یا نه. اگر نه کار پک انجام میشه و اون فایل روی سرور پاک میشه.
5- به همه اجازه اجرای برنامه اصلی داده میشه.
کمی مشکله پیاده سازیش. اما ممکنه.
.
سلام منظورتون ازفایل چه نوع فایلی است ؟
چگونه میتوانید اون فایل رو روی سرور پیدا کنید؟
من از تیبل استفاده کردم و در فرم اصلی در یک تایمر هر 3 ثانیه یکبار بانک مربوطه را چک میکنم و در صورت تائید برنامه فراخوان اجرا و مهلت مورد نظر داده میشه تا کاربر بتوانه برنامههاشو ببنده ولی باز شدن یک تیبل در تایمر اون هم هر لحظه منو ازار میده راه دیگری هست؟
رهرو

[hamed_m]

مثلا: strtofile('test',\\server\share\file.file) و بعد چک بشه if file(\\server\share\file.file) .

[mehran_337]

لیست آرایه های موجود را brow می کند


local ;
laDir(1), ;
laClasses(1), ;
laStru(1)

* Grab an array of file name info
wait window "adir()" nowait
aDir( laDir, home()+"*.*" )
aBrow( @laDir )
* Grab an array of classes
wait window "aVcxClasses()" nowait
AVCXCLASSES( laClasses, home()+ 'FFC\_Base' )
aBrow( @laClasses )
* Make an array out of the structure used to show aVcxClasses (all char)
wait window "aFields()" nowait
afields( laStru )
aBrow( @laStru )
* This is the structure structure (and where the foolishness it stops.)
wait window "aFields() again" nowait
afields( laStru )
aBrow( @laStru )
return

function aBrow( taArray )
* Makes a cursor out of a two-dimensional array
* and browses it
local ;
lnRows, ;
lnCols, ;
laStru(1), ;
lnI, lnJ, ;
lcTyp, lnSiz, lnDec, ;
lcRow
* Figure out size of array
lnRows = ALEN(taArray,1)
lnCols = max( ALEN(taArray,2), 1 )
dimension laStru(lnCols, 5)
lcRow = ""
for lnI = 1 to lnCols
* Create structure array
lcCol = ltrim(str(lnI))
laStru( lnI, 1 ) = vartype( taArray( 1, lni ) ) + lcCol
laStru( lnI, 2 ) = "C"
lnSiz = 1
for lnJ = 1 to lnRows
lnSiz = max( lnSiz, len( trans( taArray( lnJ, lnI ))))
endfor
laStru( lnI, 3 ) = lnSiz
laStru( lnI, 4 ) = 0
* Create "insert into" values
if !empty( lcRow )
lcRow = lcRow + ", "
endif
lcRow = lcRow + "transform( taArray(lnI,"+lcCol+") )"
endfor
* Make a cursor with fields defined by laStru
create cursor qArray from array laStru
* Add rows using a string of transform(taArray(lnI,1))...
for lnI = 1 to lnRows
insert into qArray values ( &lcRow )
endfor
go top
browse
return
* eof

[mehran_337]

این برنامه یک بانک اکسس را باز می کند و لیست ان را نمایش می دهد و می تواند ان بانک را به dbf تبدیل کند


Public oForm
oForm = Createobject('myForm')
oForm.Show()
Define Class myForm As Form
Height = 450
Width = 850
DataSession=2
Caption='Show Access Data'
Add Object lblAccess As Label With ;
Caption = "Access Database", ;
Left = 10, Top = 15, Width = 100
Add Object txtMDBlocation As TextBox With ;
Left = 112, Top = 12, Width = 520
Add Object cmdBrowse As CommandButton With ;
Top = 10, Left = 640, Caption = "Browse", AutoSize=.T.
Add Object cmdCreateDb As CommandButton With ;
Top = 10, Left = 700, Caption = "Create VFP Database", ;
Autosize=.T.,Enabled = .F.
Add Object lblTables As Label With ;
Caption = "Tables", Left = 20, Top = 40, Width = 40
Add Object lstTables As ListBox With ;
Height = 400, Left = 65, Top = 40, Width = 265
Add Object grdShow As Grid With ;
Height = 400, Left = 340, Top = 40, Width = 500
Procedure listtables
Local lnConnHandle,lcMDB
With This.txtMDBlocation
If Empty(.Value) Or !File(.Value)
Return
Endif
lcMDB = Trim(.Value)
Endwith
lnConnHandle = Sqlstringconnect("Driver={Microsoft Access Driver (*.mdb)};Uid=Admin;DBQ="+m.lcMDB)
SQLTABLES(m.lnConnHandle, ['TABLE'], 'crsTables')
SQLDISCONNECT(m.lnConnHandle)
Select crsTables
This.lstTables.Clear()
Scan
This.lstTables.AddItem(crsTables.table_name)
Endscan
This.cmdCreateDb.Enabled = .T.
Endproc
Procedure txtMDBlocation.LostFocus
Thisform.listtables()
Endproc
Procedure cmdBrowse.Click
This.Parent.txtMDBlocation.Value = Getfile('MDB','','',0,'Select Access Database')
Thisform.listtables()
Endproc
Procedure lstTables.InteractiveChange
Local lnConnHandle,lcMDB,lcSQL
With This.Parent.txtMDBlocation
If Empty(.Value) Or !File(.Value)
Return
Endif
lcMDB = Trim(.Value)
Endwith
lcSQL = 'select * from "'+Trim(This.Value)+'"'
lnConnHandle = Sqlstringconnect("Driver={Microsoft Access Driver (*.mdb)};Uid=Admin;DBQ="+m.lcMDB)
SQLEXEC(m.lnConnHandle,m.lcSQL,'crsLocal')
SQLDISCONNECT(m.lnConnHandle)
With This.Parent.grdShow
.ColumnCount = -1
.RecordSource = 'crsLocal'
Endwith
Endproc
Procedure cmdCreateDb.Click
Local lcFileName,lcViewName, lcConnection, lcFrom
lcFileName = Putfile("VFP Db name","MyAccessDb.dbc","DBC")
If Empty(m.lcFileName)
Return
Endif
lcConnection = "Driver={Microsoft Access Driver (*.mdb)};Uid=Admin;DBQ="+;
TRIM(This.Parent.txtMDBlocation.Value)
Create Database (m.lcFileName)
Create Connection accessCn Connstring m.lcConnection
Select crsTables
Scan
lcViewName = Chrtran(Trim(crsTables.table_name),' $','_')
lcFrom = "["+Trim(crsTables.table_name)+"]"
Create Sql View (m.lcViewName) ;
Remote Connection "accessCn" ;
As Select * From &lcFrom
Endscan
Endproc
Enddefine

[rezakhj]

ممنونم داشتم یک سیستم حضور و غیاب برای ادارم می نوشتم که به این کد نیاز اساسی داشتم 2 روز بود داشتم جمع و تفریق می کردم چطوری ساعتها را کم کنم

[farhad_shiri_ex]

با سلام !
فقط میتونم بگم خیلی عالی که دوستان در سطح خوبی از V-fox دارن استفاده میکنند و کدهای قابل تاملی رو ارسال میکنند .
هر چند ما شاگردیم اما سعی میکنم منهم در این پست شرکت کنم.

[mostafa_zamani]

با تقدیم سلام و احترام
و تشکر از کد جنابعالی

بنده این کد را به صورت زیر در برنامه ام استفاده نمودم :
DECLARE ExitProcess IN WIN32API INTEGER
ON KEY LABEL ALT+F4 ExitProcess(0)

آیا جنابعالی این روش استفاده را صلاح می دانید ؟
و اگر جدولهای برنامه باز باشند و این دستور اجرا شود آیا ممکن است باعث خرابی جدولها شود ؟




پیش آمده که موقع خروج از برنامه به مشکل بر بخورید؟ یه راه حل ساده اما نه چندان استاندارد:



DECLARE ExitProcess IN WIN32API INTEGER
ExitProcess(0)

[masoud8880]

این کد اختلاف زمان بین دو ساعت را بر می گرداند:


FUNCTION TimeDif
PARAMETERS tDateTime1, tDateTime2

LOCAL lReturn, myHours, myMinutes, mySeconds
lReturn = .t.

IF PARAMETERS() # 2
lReturn = .f.
ENDIF
IF ! VARTYPE(tDateTime1) = "T"
lReturn = .f.
ENDIF
IF ! VARTYPE(tDateTime2) = "T"
lReturn = .f.
ENDIF
IF lReturn
IF tDateTime2 > tDateTime1
mySeconds = tdateTime2 - tDateTime1
ELSE
mySeconds = tdateTime1 - tDateTime2
ENDIF
mySeconds=INT(mySeconds)
cTime = TRANSFORM(INT(mySeconds/3600),"9999")+":"+ ;
TRANSFORM(MOD(INT(mySeconds/60),60),"99")+":"+ ;
TRANSFORM(MOD(mySeconds,60),"99")
WAIT WINDOW "Time Difference = "+cTime
RETURN cTime
ELSE
=MESSAGEBOX("Pass to this function ;
From DateTime and To DateTime", ;
0+16,"Wrong Parameters")
RETURN lReturn
ENDIF


با سلام به آقا مهران
ببخشید چطوری میشه این فانکشن ها رو در برنامه اصلی اجرا کرد ؟
ایا برنامه ایی دارید که بشه روز یک هفته رو به فارسی برگردونه ؟

[amir_1351]

این کد لیست تمام شاخه ها و زیر شاخه ها را در یک جدول ذخیره می کند.


************************************************** *******
** Author : Ramani (Subramanian.G)
** FoxAcc Software / Winners Software
** ramani_vfp@yahoo.com
** Type : Freeware with reservation to Copyrights
** Warranty : Nothing implied or explicit
** Last modified : 31 January, 2003
************************************************** *******
** The following uses Filer.DLL and
** extracts all files in a directory as a cursor.
** How to run : Save this as dir2Cursor.prg
** =dir2Cursor(cDir)
************************************************** *******
** FUNCTION dir2cursor
PARAMETERS pDir
IF PARAMETERS() < 1 OR EMPTY(pDir)
RETURN
ENDIF
pDir = ADDBS(ALLTR(pDir))
CREATE CURSOR filename (cfilename c(128))
omyfiler = CREATEOBJECT('Filer.FileUtil')
omyfiler.searchpath = pDir && Search Directory
omyfiler.subfolder = 1 && 1=add all subdirectories else 0
oMyFiler.SortBy = 0
omyfiler.FIND(0)
LOCAL ncount
ncount = 1
FOR nfilecount = 1 TO omyfiler.FILES.COUNT
IF omyfiler.FILES.ITEM(nfilecount).NAME = "." OR ;
omyfiler.FILES.ITEM(nfilecount).NAME = ".."
LOOP
ENDIF
APPEND BLANK
REPLACE cfilename ;
WITH UPPER(omyfiler.FILES.ITEM(nfilecount).PATH)+ ;
UPPER(omyfiler.FILES.ITEM(nfilecount).NAME)
ENDFOR
BROW
************************************************** *******
* EOF




با سلام خدمت اساتيد
با وجود اينكه چند سال از اين پست گذشته :
اين برنامه فايلهاي مخفي (HIDDEN ) رو نمياره
آيا راهي وجود داره تا بتوان تمام فايلها و فولدرها حتي اونهايي كه مخفي هستند را بياورد ؟
لطفا راهنمايي كنيد

[amir_1351]

لطفا يكي از دوستان راهنمايي كند

[hamed_m]

ADIR:
http://msdn.microsoft.com/en-US/library/0tf1t016(v=vs.80).aspx
فایلهای مخفی رو لیست میکنه.







همه دوستان درود و خسته نباشید.

[hamed_m]

کنترل کلیک راست رو تغییر بدید:




LOCAL lEsc
lESC = SET("ESCAPE")

DEFINE POPUP myPopup SHORTCUT RELATIVE FROM MROW(),MCOL()
DEFINE BAR 1 OF myPopup PROMPT "پاک کردن"
DEFINE BAR 2 OF myPopup PROMPT "لغو پاک کردن"
ON SELECTION POPUP myPopup DEACTIVATE POPUP

ACTIVATE POPUP myPopup
DO CASE
CASE BAR() = 1
DELETE NEXT 1
CASE BAR() = 2
RECALL NEXT 1
ENDCASE
************
RELEASE POPUP myopup
SET ESCAPE &lESC

[hamed_m]

فضای خالی دیسک:



myFSO = CREATEOBJ('Scripting.FileSystemObject')
myDrive = myFSO.GetDrive("C:")
? myDrive.AvailableSpace

[frahimi]

مرسی خیلی خوب بود . اگه از فاکس به اکسس هم داری ممنون میشم کد آنرا قراردهی.

[frahimi]

با سلام اگر امکان دارد در مورد این تابع بیشتر توضیح دهید. با مثال. متشکرم

[hamed_m]

شاخه جاری:


SYS(5)+SYS(2003)

[gh_khajehzade]

سلام
تشکر دوست عزیز!