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

[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/presentatio...foxunicode.asp

[mehran_337]

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

[hamed_m]

ممنون از لطفتون مهران عزیز.
اینهم کمی در مورد ترمینیت:
http://www.urbandictionary.com/defin...erm=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/libr...(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]

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