# پایگاه‌های داده > سایر پایگاه‌های داده > Foxpro >  تکه کد های جالب

## 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_NetworkAdapterConfigurati  on")
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,gvTyp  eA))"
      .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)
> ...


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

----------


## 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",lcOperatio  n,"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/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
> ...


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

----------


## 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
> ...


با سلام خدمت اساتيد 
با وجود اينكه چند سال از اين پست گذشته :
اين برنامه فايلهاي مخفي (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

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

----------

