ايران ويج - BASIC

محیط ترمینال

Fri, 24 Nov 2017 12:17:42 +0000

سلام

همگی خوبین؟

همونطور که میدونین برای ارتباط محیط بیرون (مثل میکروکنترولر) با کامپیوتر نیاز به یه نرم افزار آشکارسازی مثل ترمینال هستش که خود ترمینال انواع مختلفی داره ..

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

حالا سوال من اینه که میخوام دیتاهایی رو که در محیط ترمینال ثبت میشه همزمان روبروی هر سطر از دیتا زمان و تاریخ هم بصورت اتوماتیک ثبت بشه

چطوری اینکارو انجام بدم؟

با ترمینال خود بسکام میشه اینکارو کرد یا یه ترمینال دیگه میخواد؟

عکسهای زیر رو بعنوان مثال میذارم ، شماره یک ترمینال معمولی خودشه اما شماره دو رو دستی تاریخ و ساعت گذاشتم که میخوام مثل همین باشه ..

1.jpg (اندازه: 61.99 KB / تعداد دفعات دریافت: 98)

2.jpg (اندازه: 88.74 KB / تعداد دفعات دریافت: 98)

محیط بسکام

Sat, 27 Aug 2016 12:10:43 +0000

سلام
برای تو محیط بسکام وقتی = رو میذارم ارور زیر رو بهم میده
این مشکل سازه؟!
باید چکارش کنم

There was an error during the execution of this program.

The application might become unstable and even useless.

It's recommended that you save your work and close this application.

Access violation at address 008D7965 in module 'bascavr.exe'. Read of address 00000000

برنامه موتور پله ای با بیسکام

Sat, 12 Dec 2015 15:15:14 +0000

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

الف- برنامه چرخش یک موتور پله ای 4 قطب با زاويه پله 1.8 درجه با کنترل تمام پله را به صورتی تغییر دهید که موتور تنها نیم دور بچرخد.

ب-برنامه چرخش یک موتور پله ای 4 قطب با زاويه پله 1.8 درجه به طور دائم با کنترل نیم پله را به زبان بيسيك در محیط BASCOM-AVR بنویسید.

ج-برنامه اولیه را به گونه اي تغيير دهيد كه وضعيت يك كليد را در ورودي خوانده و بسته به آن جهت چرخش موتور را تغییر دهد یعنی اگر يك بود موتور پله ای را ساعتگرد و اگر صفر بود موتور پله ای را پادساعتگرد بچرخاند.

د- برنامه نمایش یک متن ثابت را روی LCD متنی 16*2 بنویسید.

ایشاالله هر چی از خدا میخواهید بهتون بده

Qbasic Source Codes

Mon, 13 Oct 2014 12:40:10 +0000

درود

در این تاپیک سورس کد های qb قرار خواهد گرفت.

نکته:سورس ها برای ویندوز نوشته شده اند اما امکان اجرای اکثر ان ها بر روی سیستم عامل های دیگر امکان پذیر میباشد.

موفق باشید.

HP Basic

Mon, 18 Nov 2013 11:42:21 +0000

با سلام
من پروژه ای دارم که در آن از زبان HP Basic استفاده شده است. برنامه موقع اجرا error میگیرد. نیاز به کسی دارم که کمک کند تا مشکل را پیدا کنم. لطفا از افرادی که به این زبان آگاهی دارند خواهش میکنم پیام بدن.
با تشکر

محاسبه عددی بزرگ

Fri, 20 Apr 2012 07:37:38 +0000

با سلام
من می خوام دو عدد بسیار بزرگ رو روشون عملیات ریاضی انجام دهم مثلا در هم ضربشون کنم از اونجایی که هیچ متغیری نمی تونه کل هدد رو ذخیره کته Qbasic ارور overflow میده راه حلی برای این مشکل میدونید؟

درخواست PowerBasic Decompiler - دیکامپایلر پاور بیسیک

Wed, 09 Feb 2011 19:10:55 +0000

دوستان کسی PowerBasic Decompiler - دیکامپایلر پاور بیسیک

سراغ نداره؟

یک برنامه خارجی دارم که با PowerBasic 7.02 نوشته شده و من می خوام سورس برنامه رو ببینم.

لطفا کمک کنین.
احتیاج مبرم دارم.

Powerbasic download

Tue, 18 Jan 2011 11:58:30 +0000

windows
console

مخقی سازی چند فایل در یک فایل

Sat, 28 Aug 2010 09:50:43 +0000

سلام دوستان

شما در نظر بگیرید ما 4 فایل داریم
1.mp3
2.exe
3.jpg
4.dll

بعد می خواهم اون رو در یک فایل eXE یا bat جا بدم که هر وقت کسی EXE رو باز کرد فایل mp3 و exe براش باز بشه باید چکاری انجام بدم

تشکر

ارتباط با پورت سریال

Sun, 28 Jun 2009 14:00:55 +0000

با سلام

من میخوام با vb یه برنامه بنویسم که یه سری اطلاعات رو با پورت سریال با میکرو avr مبادله کنم یعنی هم بفرستم و هم بگیرم

ازاساتیدی که با vb کارکردند ممونو میشم راهنمائی بفرمائین
برنامه میکرو رو مشکل ندارم اما مشکلم اینجاس که vb زیاد کار نکردم
مرسی

چند تابع برای ساخت یک فایل Bitmap

Sat, 21 Mar 2009 05:05:40 +0000

کد زیر حاوی چند تابع برای ساخت فایلهای bitmap ه

توضیح توابع :

نقل قول: ShiftLeft و ShiftRight عمل شیفت به چپ و راست را در ivar به مقدار icount انجام می دهند
CreateBitmapInfoStruct برای ساخت و تنظیم هدر و ساختمان فایل bitmap به کار می رود
CreateBMPFile آخرین تابع در ساخت این نوع فایلها که تنظیمات را دریافت و فایل bmp را می سازد

کد: 
%MAXWRITE = 4096                          '4 Kbyte

TYPE BITMAPINFOQ                          'Modified version of BITMAPINFO

  bmiHeader AS BITMAPINFOHEADER

  bmiColors AS STRING*(256*4)             '256 * SIZEOF(RGBQUAD)

END TYPE

FUNCTION ShiftLeft (BYVAL iVar AS LONG, BYVAL iCount AS LONG) AS LONG

  LOCAL iRes AS LONG

  iRes = iVar

  SHIFT LEFT iRes, iCount

  FUNCTION = iRes

END FUNCTION

FUNCTION ShiftRight (BYVAL iVar AS LONG, BYVAL iCount AS LONG) AS LONG

  LOCAL iRes AS LONG

  iRes = iVar

  SHIFT RIGHT iRes, iCount

  FUNCTION = iRes

END FUNCTION

' ----------------------------------------------------------------

'FUNCTION CreateBitmapInfoStruct (BYVAL hBmp      AS DWORD,_

'                                       bmiHeader AS BITMAPINFOHEADER) AS LONG

'    This function initialises the members of a BITMAPINFOHEADER structure

'    for an uncompressed bitmap.  Returns %TRUE for success, else %FALSE.

'

FUNCTION CreateBitmapInfoStruct (BYVAL hBmp      AS DWORD,_

                                       bmiHeader AS BITMAPINFOHEADER) AS LONG

  LOCAL bmp      AS BITMAP,_

        cClrBits AS WORD

  FUNCTION = %FALSE

  'Retrieve the bitmap's color format, width, and height

  '-----------------------------------------------------

  IF 0 = GetObject(hBmp, SIZEOF(bmp), bmp) THEN EXIT FUNCTION

  'Convert the color format to a count of bits

  '-------------------------------------------

  SELECT CASE AS LONG (bmp.bmPlanes * bmp.bmBitsPixel)

    CASE 1      :cClrBits =  1

    CASE <= 4   :cClrBits =  4

    CASE <= 8   :cClrBits =  8

    CASE <= 16  :cClrBits = 16

    CASE <= 24  :cClrBits = 24

    CASE ELSE   :cClrBits = 32

  END SELECT

  'Initialize the fields in the BITMAPINFO structure

  '-------------------------------------------------

  bmiHeader.biSize     = SIZEOF(BITMAPINFOHEADER)

  bmiHeader.biWidth    = bmp.bmWidth

  bmiHeader.biHeight   = bmp.bmHeight

  bmiHeader.biPlanes   = bmp.bmPlanes

  bmiHeader.biBitCount = bmp.bmBitsPixel

  IF cClrBits < 24 THEN bmiHeader.biClrUsed = ShiftLeft(1, cClrBits)

  'Since bitmap is uncompressed, set the BI_RGB flag

  '-------------------------------------------------

  bmiHeader.biCompression = %BI_RGB

  'Compute the number of bytes in the array of color indices *.

  '---------------------------------------------------------

  bmiHeader.biSizeImage = _

    ((bmiHeader.biWidth*cClrBits + 31) AND NOT(31)) / 8 _

                                   * bmiHeader.biHeight

  'Set biClrImportant to 0, indicating that all of the

  'device colors are important.

  '------------------------------

  bmiHeader.biClrImportant = 0

  FUNCTION = %TRUE

END FUNCTION

'NOTE: * For Windows NT, the width must be DWORD aligned unless the bitmap

'      is RLE compressed. This example shows this.  For Windows 95/98/Me,

'      the width must be WORD aligned unless the bitmap is RLE compressed.

'

' --------------------------------------------------------------

'FUNCTION CreateBMPFile (sFile AS STRING, hBmp AS DWORD, hDC AS DWORD) AS LONG

'

'    Saves a bitmap to a file.  Returns %TRUE for success, else %FALSE.

'

FUNCTION CreateBMPFile (sFile AS STRING, hBmp AS DWORD, hDC AS DWORD) AS LONG

  LOCAL iRet    AS LONG,_

        dwTmp   AS LONG,_

        hf      AS DWORD,_                   'file handle

        pbi     AS BITMAPINFOQ,_

        hdr     AS BITMAPFILEHEADER,_        'bitmap file-header

        pbih    AS BITMAPINFOHEADER,_        'bitmap info-header

        lpBits  AS STRING,_                  'memory buffer

        dwTotal AS DWORD,_                   'total count of bytes

        cb      AS DWORD,_                   'incremental count of bytes

        hp      AS BYTE PTR                  'byte pointer

  iRet = %FALSE

  FUNCTION = iRet

  'Create BITMAPINFO structure

  '---------------------------

  IF ISFALSE CreateBitmapInfoStruct (hBmp, pbi.bmiHeader) THEN EXIT FUNCTION

  'Initialize BITMAPINFOHEADER fields

  '----------------------------------

  pbih = pbi.bmiHeader

  'Get bits array and color table (RGBQUAD array)

  '----------------------------------------------

  lpBits = SPACE$(pbih.biSizeImage)             'Buffer for bitmap bits

  IF 0 = GetDIBits (hDC, hBMP, 0, pbih.biHeight, BYVAL STRPTR(lpBits),_

                    BYVAL VARPTR(pbi), %DIB_RGB_COLORS) THEN EXIT FUNCTION

  'Initialize fields of BITMAPFILEHEADER

  '-------------------------------------

  hdr.bfType = &H4D42                           '"BM",ie. &H42 = "B" &H4D = "M"

  hdr.bfOffBits = SIZEOF(hdr) + pbih.biSize _   'Offset to bitmap bits

                + pbih.biClrUsed*SIZEOF(RGBQUAD)

  hdr.bfSize = hdr.bfOffBits + pbih.biSizeImage 'Size of entire file

  hdr.bfReserved1 = 0

  hdr.bfReserved2 = 0

  'Create the .BMP file

  '--------------------

  hf = CreateFile (BYVAL STRPTR(sFile), %GENERIC_READ OR _

                                        %GENERIC_WRITE, 0, BYVAL %NULL, _

                                        %CREATE_ALWAYS, _

                                        %FILE_ATTRIBUTE_NORMAL, %NULL)

  IF hf = %INVALID_HANDLE_VALUE THEN EXIT FUNCTION

  'Copy BITMAPFILEHEADER into .BMP file

  '------------------------------------

  IF 0 = WriteFile (hf, hdr,  SIZEOF(hdr),_

                              dwTmp, BYVAL %NULL) THEN GOTO CloseBMP

  'Copy the BITMAPINFOHEADER into the file

  '---------------------------------------

  IF 0 = WriteFile (hf, pbih, SIZEOF(pbih),_

                              dwTmp, BYVAL %NULL) THEN GOTO CloseBMP

  'Copy the RGBQUAD array into the file

  '------------------------------------

  IF pbih.biClrUsed THEN

    IF 0 = WriteFile (hf, pbi.bmiColors, pbih.biClrUsed*SIZEOF(RGBQUAD), _

                                         dwTmp, BYVAL %NULL) THEN GOTO CloseBMP

  END IF

  'Copy the bitmap bits into the file

  '----------------------------------

  dwTotal = pbih.biSizeImage

  cb      = dwTotal

  hp      = STRPTR(lpBits)

  WHILE cb > %MAXWRITE

    IF 0 = WriteFile (hf, BYVAL hp, %MAXWRITE,_

                                    dwTmp, BYVAL %NULL) THEN GOTO CloseBMP

    cb = cb - %MAXWRITE

    hp = hp + %MAXWRITE

  WEND

  IF 0 = WriteFile (hf, BYVAL hp, cb, dwTmp, BYVAL %NULL) THEN GOTO CloseBMP

  iRet = %TRUE

  'Close the .BMP file

  '-------------------

CloseBMP:

  CALL CloseHandle (hf)

  FUNCTION = iRet

END FUNCTION

خواندن اطلاعات یک PDF

Mon, 09 Mar 2009 14:28:03 +0000

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

به سورس نزدم و همون اصلش رو گذاشتم چون زیاد سورس از کنسول نذاشته بودم

کد: 
#Compile Exe

#Dim All

#Include "Win32API.inc"

Type TPdfObj

    number As Long

    offset As Long

End Type

Type TPdfInfo

    author          As Asciiz * 80

    creator         As Asciiz * 80

    producer        As Asciiz * 80

    keywords        As Asciiz * 512

    subject         As Asciiz * %MAX_PATH

    title           As Asciiz * %MAX_PATH

    creationDate    As Asciiz * 32

    modDate         As Asciiz * 32

    pageCount       As Long

    fileSize        As Quad

    version         As Asciiz * 6

    linearized      As Byte

    tagged          As Byte

    encrypted       As Byte

End Type

%BUF_SIZE       = 1024

%ERR_PASSED_BOF = 151

%ERR_NAN        = 152

%ERR_NO_TRAILER = 153

%ERR_NOT_FOUND  = 154

Sub STDOUT(sOut As String)

    Static hConsole As Dword

    Local bWritten As Dword

    If hConsole = 0 Then AllocConsole: hConsole = GetStdHandle(%STD_OUTPUT_HANDLE)

    WriteFile hConsole,ByVal StrPtr(sOut),Len(sOut),bWritten,ByVal %NULL

End Sub

Sub Usage()

    STDOUT "Usage:" & $CrLf

    STDOUT "pdfinfo path" & $CrLf

End Sub

'-- Avoid need for global variable hFile

Function GetOrSetHandle(h As Long) As Long

    Static hFile As Long

    If hFile = 0 Then

        hFile = h

    End If

    Function = hFile

End Function

Function GetData(offset As Quad, ln As Long) As String

    Local tmp As String

    Local hFile As Long

    hFile = GetOrSetHandle(0)

    Seek #hFile, offset

    Get$ #hFile, ln, tmp

    Function = tmp

End Function

Function GetNumber(p As Quad, num As Long) As Long

    Local tmpStr As String

    Local ch As String

    Function = %FALSE

    Do While GetData(p, 1) < "!"

        Incr p

    Loop

    ch = GetData(p, 1)

    Do While (ch >= "0" And ch <= "9")

        tmpStr = tmpStr & ch

        Incr p

        ch = GetData(p, 1)

    Loop

    If tmpStr = "" Then Exit Function

    num = Val(tmpStr)

    Function = %TRUE

End Function

Function GetString(p As Quad, str As Asciiz) As Long

    Local tmp As String

    Local lp As Long

    Local ms As String

    Function = %FALSE

    ms = "/" & $CrLf

    Do While GetData(p, 1) < "!"

        Incr p

    Loop

    tmp = GetData(p, %BUF_SIZE)

    '-- Find terminator

    lp = InStr(tmp, Any ms)

    tmp = Left$(tmp, lp-1)

    '-- Is it Unicode encoded?

    If Asc(Mid$(tmp,2,1)) = 254 Then

        '-- If yes, convert to ascii

        tmp = ACode$(Mid$(tmp, 3))

    End If

    '-- Trim enclosing ()

    lp = InStr(-1, tmp, ")")

    If lp > 0 Then

        tmp = Left$(tmp, lp-1)

    End If

    If Left$(tmp, 1) = "(" Then

        tmp = Mid$(tmp, 2)

    End If

    '-- Remove escape char

    tmp = Remove$(tmp, "\")

    If Len(tmp) > 0 Then

        Function = %TRUE

        str = Trim$(tmp)

    Else

        str = ""

    End If

End Function

Function IsString(p As Quad, str As String) As Long

    Local ln As Long

    ln = Len(str)

    If GetData(p, ln) = str Then

        Function = %TRUE

    Else

        Function = %FALSE

    End If

    p = p + ln

End Function

Function FindStrInDict(p As Quad, str As String) As Long

    Local tmp As String

    Local lp As Long

    Function = %FALSE

    tmp = GetData(p, %BUF_SIZE)

    lp = InStr(tmp, str)

    If lp > 0 Then

        p = p + lp -1

        Function = IsString(p, str)

        Exit Function

    End If

End Function

Function GetPdfInfo(filename As String, PdfInfo As TPdfInfo) As Long

    Dim PdfObjList(0 To 0) As TPdfObj

    Local k As Long

    Local cnt As Long

    Local pagesNum As Long

    Local rootNum As Long

    Local infoNum As Long

    Local ch As String

    Local p As Quad

    Local p2 As Quad

    Local hFile As Long

    Function = 0

    Try

        hFile = FreeFile

        Call GetOrSetHandle(hFile)

        Open filename For Binary Access Read As #hFile Base=0

        '-- Get file size

        PdfInfo.fileSize = Lof(hFile)

        '-- Get the PDF version

        p = 5

        Call GetString(p, PdfInfo.version)

        '-- Find 'startxref' ignoring '%%EOF'

        p = Lof(hFile) - 5

        p2 = 0

        Do

            ch = GetData(p, 1)

            Do While (p > p2) And (ch <> "f")

                Decr p

                ch = GetData(p, 1)

            Loop

            If (p <= p2) Then Error %ERR_PASSED_BOF

            If LCase$(GetData(p-8, 9)) = "startxref" Then Exit Do

            Decr p

        Loop

        Incr p

        rootNum = -1 '-- Flags not yet found

        infoNum = -1

        '-- xref offset ==> k

        If IsFalse GetNumber(p, k) Then Error %ERR_NAN

        p = k + 4

        Do

            '-- get base object number ==> k

            If IsFalse GetNumber(p, k) Then Error %ERR_NAN

            '-- get object count ==> cnt

            If IsFalse GetNumber(p, cnt) Then Error %ERR_NAN

            ch = GetData(p, 1)

            Do While IsFalse(ch >= "0" And ch <= "9")

                Incr p

                ch = GetData(p, 1)

            Loop

            p2 = p

            '-- add all objects in section to list ...

            For cnt = 0 To cnt-1

                ReDim Preserve PdfObjList(UBound(PdfObjList) + 1)

                PdfObjList(UBound(PdfObjList)).number = k + cnt

                If IsFalse GetNumber(p, PdfObjList(UBound(PdfObjList)).offset) Then Error %ERR_NAN

                p2 = p2 + 20

                p = p2

            Next cnt

            ch = GetData(p, 1)

            If IsTrue(ch >= "0" And ch <= "9") Then Iterate Loop

            If IsFalse IsString(p, "trailer") Then Error %ERR_NO_TRAILER

            '-- Find the /Encrypt object

            p2 = p

            If IsTrue FindStrInDict(p, "/Encrypt") Then

                PdfInfo.encrypted = %TRUE

            End If

            p = p2

            '-- Find the /Info object

            p2 = p

            If (infoNum = -1) And IsTrue FindStrInDict(p, "/Info") Then

                If IsFalse GetNumber(p, infoNum) Then Error %ERR_NAN

            End If

            p = p2

            '-- Find the /Root object

            If (rootNum = -1) And IsTrue FindStrInDict(p, "/Root") Then

                If IsFalse GetNumber(p, rootNum) Then Error %ERR_NAN

            End If

            p = p2

            If (rootNum <> -1) And (infoNum <> -1) Then

                If IsFalse FindStrInDict(p, "/Prev") Then Exit Do

            End If

            If IsFalse GetNumber(p, k) Then Error %ERR_NAN

            p = k + 4

        Loop

        If rootNum < 0 Then Error %ERR_NOT_FOUND

        '-- Find "Linearized" (Optimized) and "StructTreeRoot" (Tagged) keys

        k = 0

        Do While k < UBound(PdfObjList)

            p = PdfObjList(k).offset

            If FindStrInDict(p, "/Linearized 1") Then

                PdfInfo.linearized = %TRUE

'            elseif FindStrInDict(p, "/StructTreeRoot") then

'                PdfInfo.tagged = %TRUE

            End If

            Incr k

        Loop

        If infoNum > 0 Then

            Try

                k = 0

                Do While k < UBound(PdfObjList)

                    If PdfObjList(k).number = infoNum Then Exit Do

                    Incr k

                Loop

                If k = UBound(PdfObjList) Then Error %ERR_NOT_FOUND

                p = PdfObjList(k).offset

                If IsFalse GetNumber(p, k) Or (k <> infoNum) Then Error %ERR_NAN

                p2 = p

                If FindStrInDict(p, "/CreationDate") Then GetString p, PdfInfo.creationDate

                p = p2

                If FindStrInDict(p, "/ModDate") Then GetString p, pdfInfo.modDate

                p = p2

                If FindStrInDict(p, "/Producer") Then GetString p, PdfInfo.producer

                p = p2

                If FindStrInDict(p, "/Author") Then GetString p, PdfInfo.author

                p = p2

                If FindStrInDict(p, "/Creator") Then GetString p, pdfInfo.creator

                p = p2

                If FindStrInDict(p, "/Title") Then GetString p, pdfInfo.title

                p = p2

                If FindStrInDict(p, "/Subject") Then GetString p, pdfInfo.subject

                p = p2

                If FindStrInDict(p, "/Keywords") Then GetString p, pdfInfo.keywords

            Catch

                '-- Ignore info errors

            End Try

        End If

        k = 0

        Do While k < UBound(PdfObjList)

            If PdfObjList(k).number = rootNum Then Exit Do

            Incr k

        Loop

        If k = UBound(PdfObjList) Then Error %ERR_NOT_FOUND

        p = PdfObjList(k).offset

        If IsFalse GetNumber(p, k) Or (k <> rootNum) Then Error %ERR_NAN

        If IsFalse FindStrInDict(p, "/Pages") Then Error %ERR_NOT_FOUND

        If IsFalse GetNumber(p, pagesNum) Then Error %ERR_NAN

        k = 0

        Do While k < UBound(PdfObjList)

            If PdfObjList(k).number = pagesNum Then Exit Do

            Incr k

        Loop

        If k = UBound(pdfObjList) Then Error %ERR_NOT_FOUND

        p = PdfObjList(k).offset

        If IsFalse GetNumber(p, k) Or (k <> pagesNum) Then Error %ERR_NAN

        If IsFalse FindStrInDict(p, "/Count") Then Error %ERR_NOT_FOUND

        If IsFalse GetNumber(p, cnt) Then Error %ERR_NAN

        If IsTrue GetNumber(p, k) And IsString(p, " R") Then

            k = 0

            Do While k <= UBound(PdfObjList)

                If PdfObjList(k).number = cnt Then Exit Do

                Incr k

            Loop

            If k > UBound(PdfObjList) Then Error %ERR_NOT_FOUND

            p = PdfObjList(k).offset

            If  IsFalse GetNumber(p, k) Or _

                IsFalse GetNumber(p, k) Or _

                IsFalse IsString(p, " obj") Or _

                IsFalse GetNumber(p, cnt) Then

                    Error %ERR_NAN

            End If

        End If

    Catch

        Select Case Err

            Case %ERR_NAN

                STDOUT "Error: PDF file is damaged." & $CrLf

            Case %ERR_PASSED_BOF

                STDOUT "Error: PDF file is damaged." & $CrLf

            Case %ERR_NO_TRAILER

                STDOUT "Error: Couldn't find trailer dictionary." & $CrLf

            Case %ERR_NOT_FOUND

                STDOUT "Error: Object not found." & $CrLf

            Case Else

        End Select

        Function = Err

    Finally

        Close #hFile

    End Try

    PdfInfo.pageCount = cnt

End Function

Function PBMain() As Long

    Local ret As Long

    Local Path As String

    Local PdfInfo As TPdfInfo

    Local msg As String

    Path = Remove$(Command$, $Dq)

    If Path = "" Then

        Usage

        Function = 1

        Exit Function

    End If

    ret = GetPdfInfo(Path, PdfInfo)

    If ret = 0 Then

                msg = _

                "Title:        " & PdfInfo.title & $CrLf & _

                "Subject:      " & PdfInfo.subject & $CrLf & _

                "Keywords:     " & PdfInfo.keywords & $CrLf & _

                "Author:       " & PdfInfo.author & $CrLf & _

                "Creator:      " & PdfInfo.creator & $CrLf & _

                "Producer:     " & pdfInfo.producer & $CrLf & _

                "CreationDate: " & pdfInfo.creationDate & $CrLf & _

                "ModDate:      " & pdfInfo.modDate & $CrLf & _

                _ ' "Tagged:       " & iif$(PdfInfo.tagged, "yes", "no") & $CRLF & _

                "Pages:        " & Trim$(Str$(PdfInfo.pageCount)) & $CrLf & _

                "Encrypted:    " & IIf$(PdfInfo.encrypted, "yes", "no") & $CrLf & _

                "File size:    " & Trim$(Str$(PdfInfo.fileSize)) & " bytes" & $CrLf & _

                "Optimized:    " & IIf$(PdfInfo.linearized, "yes", "no") & $CrLf & _

                "PDF version:  " & PdfInfo.version & $CrLf

                STDOUT msg

    End If

    Sleep 2000

End Function

C Run-Time Library برای پاوربیسیک

Tue, 24 Feb 2009 09:38:04 +0000

اینجا هدر مورد استفاده توسط کامپایلر C و ++C به هدرهای پاوربیسیک تبدیل می شود

که این سرفایلها(هدرها) را در پوشه WinAPI کامپایلر پاوربیسیک کپی کنید

و با فراخوانی آنها توسط دستور Include می توانید از توابع آنها استفاده کنید برای مثال

کد: 
#Include "Time.inc"

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

1-هدر Time.h که به Time.inc تبدیل شده است

2-هدر Float.h که به Float.Inc تبدیل شده است

3-هدر Ctype.h که به Ctype.inc تبدیل شده است

4-هدر math.h که به Math.Inc تبدیل شده است

5-هدر Stdio.h که به Stdio.Inc تبدیل شده است

6-هدر fcntl.h که به Fcntl.Inc تبدیل شده است

7-هدر Io.h که به IO.Inc تبدیل شده است

8-هدر direct.h که به Direct.Inc تبدیل شده است

9-هدر conio.h که به Conio.Inc تبدیل شده است

10-هدر mbctype.h که به Mbctype.Inc تبدیل شده است

11-هدر memory.h که به Memory.Inc تبدیل شده است

12-هدر string.h که به String.inc تبدیل شده است

13-هدر search.h که به Search.Inc تبدیل شده است

14-هدر malloc.h که به Malloc.Inc تبدیل شده است

15-هدر locking.h که به Locking.Inc تبدیل شده است

16-هدر stat.h که به Stat.Inc تبدیل شده است

17-هدر mbstring.h که به Mbstring.Inc تبدیل شده است

C RunTime Lib For PB.zip (اندازه: 29.13 KB / تعداد دفعات دریافت: 128)

دیس اسمبلر فایلهای midi

Mon, 23 Feb 2009 14:20:04 +0000

برنامه رو کامپایل و باز کنید،سپس فایل MIDI رو گرفته و به دورن برنامه بیندازید و اطلاعات را ذخیره کنید

کد: 
#Compile Exe "MidiDisAsm.exe"

#Dim All

#Register All

'**************************************

'from IncLean file

%WINAPI = 1

%TRUE = 1

%FALSE = 0

%MAX_PATH = 260 ' max. length of full pathname

%wm_destroy = &H2

%wm_initdialog = &H110

%wm_command = &H111

%WM_DROPFILES = &H233

%ws_popup = &H80000000

%ws_child = &H40000000

%ws_visible = &H10000000

%ws_clipsiblings = &H04000000

%ws_caption = &H00C00000 ' WS_BORDER OR WS_DLGFRAME

%ws_border = &H00800000

%ws_dlgframe = &H00400000

%ws_sysmenu = &H00080000

%ws_tabstop = &H00010000

%ws_minimizebox = &H00020000

%ws_ex_acceptfiles = &H00000010

%ws_ex_clientedge = &H00000200

%ws_ex_left = &H00000000

%ws_ex_ltrreading = &H00000000

%ws_ex_rightscrollbar = &H00000000

%ws_ex_controlparent = &H00010000

%HWND_DESKTOP = 0

%idcancel = 2

%mb_yesno = &H00000004&

%mb_iconhand = &H00000010&

%mb_iconasterisk = &H00000040&

%mb_iconerror = %mb_iconhand

%mb_iconinformation = %mb_iconasterisk

%idno = 7

%es_left = &H0&

%es_multiline = &H4&

%es_autovscroll = &H40&

%es_autohscroll = &H80&

%es_readonly = &H800&

%ss_center = &H00000001

%ds_3dlook = &H0004&

%ds_nofailcreate = &H0010&

%ds_setfont = &H0040& ' User specified font for Dlg controls

%ds_modalframe = &H0080& ' Can be combined with WS_CAPTION

%MAXPNAMELEN = 32 ' max product name length (including NULL)

%MMSYSERR_BASE = 0

%MMSYSERR_NOERROR = 0 ' no error

%MMSYSERR_BADDEVICEID = %MMSYSERR_BASE + 2 ' device ID out of range

%MMSYSERR_NODRIVER = %MMSYSERR_BASE + 6 ' no device driver present

%MMSYSERR_NOMEM = %MMSYSERR_BASE + 7 ' memory allocation error

%MMSYSERR_INVALPARAM = %MMSYSERR_BASE + 11 ' invalid parameter passed

Type MIDIOUTCAPS

 wMid As Word

 wPid As Word

 vDriverVersion As Dword

 szPname As Asciiz * %MAXPNAMELEN

 wTechnology As Word

 wVoices As Word

 wNotes As Word

 wChannelMask As Word

 dwSupport As Dword

End Type

Declare Function DragQueryFile Lib "SHELL32.DLL" Alias "DragQueryFileA" (ByVal hDrop As Dword, ByVal uiFile As Dword, lpStr As Asciiz, ByVal cch As Dword) As Dword

Declare Function midiOutGetDevCaps Lib "WINMM.DLL" Alias "midiOutGetDevCapsA" (ByVal uDeviceID As Dword, lpCaps As MIDIOUTCAPS, ByVal uSize As Dword) As Long

Declare Sub DragAcceptFiles Lib "SHELL32.DLL" Alias "DragAcceptFiles" (ByVal hwnd As Dword, ByVal fAccept As Long)

Declare Sub DragFinish Lib "SHELL32.DLL" Alias "DragFinish" (ByVal hDrop As Dword)

'**************************************

%Dlg = 101

%Lbl = 1001

%Txt = 1002

'REM out "%Abbreviate" if you want the full names of drum sounds and controllers

'to be Print#-ed instead of their abbreviations.

%Abbreviate = 1 '(this controls compiling not operation)

'de-REM "%SharpNotation" if you prefer that style

%SharpNotation = 1 '(this controls compiling not operation)

$MidiHeader = "MThd" & Chr$(0, 0, 0, 6)

$EventPrefix = "@"

$Caption = "TheirCorp's MIDI Disassembler"

$Help = "To use:" & $CrLf & _

 "In Windows Explorer, drop a file on the program's" & $CrLf & _

 "window or on it's icon." & $CrLf & _

 "From the command line, type: ""MidiDisAsm FileName""" & $CrLf & _

 "(The file extension can be omitted)"

$Ascii = Chr$(32 To 122)

#If %def(%SharpNotation)

 $Notes = "C,C#,D,D#,E,F,F#,G,G#,A,A#,B"

#Else

 $Notes = "C,Db,D,Eb,E,F,F#,G,G#,A,Bb,B"

#EndIf

'**************************************

Global hDlg As Dword

Global gs As String

Global fo As Long 'output file's handle

Global div As Dword 'division

Global tics As Dword 'ticks

Global tmpo As Dword 'tempo

Global tpq As Long 'ticks per quarter-note

Global sf As Double 'smpte format

Global sr As Double 'smpte resolution

Global moc As MIDIOUTCAPS

Global InFile As String

Global OutFile As String

'**************************************

Sub Msg(ps As String)

 Control Set Text hDlg, %Txt, ps

End Sub

'**************************************

#If %def(%Abbreviate)

'**************************************

'returns the GM drum sound for note number "nn"

Function GetGMDrumSound(nn As Long) As String

'These are numbered beginning at 35

Data Acou Bass Drum

Data Bass Drum1

Data Side Stk

Data Acou Snar

Data Clap

Data Elec Snar

Data Lo Flr Tom

Data Clsd Hi-Hat

Data Hi Flr Tom

Data Ped Hi-Hat

Data Lo Tom

Data Opn Hi-Hat

Data LoMid Tom

Data HiMid Tom

Data Crsh Cym1

Data Hi Tom

Data Rid Cym1

Data Chin Cym

Data Rid Bell

Data Tamb

Data Splsh Cym

Data Cwbell

Data Crsh Cym2

Data Vbrslp

Data Rid Cym2

Data Hi Bngo

Data Lo Bngo

Data Mut Hi Cnga

Data Opn Hi Cnga

Data Lo Cnga

Data Hi Timb

Data Lo Timb

Data Hi Agog

Data Lo Agog

Data Cabas

Data Marac

Data Shrt Whst

Data Lng Whst

Data Shrt Guir

Data Lng Guir

Data Clves

Data Hi Wd Blk

Data Lo Wd Blk

Data Mut Cuic

Data Opn Cuic

Data Mut Trngl

Data Opn Trngl

 Function = Read$(nn - 34)

End Function 'GetGMDrumSound

'**************************************

'get abbreviated controller name

'cn is a zero-based controller number

Function GetControllerName(cn As Long) As String

'Defined Controllers

Data Bank

Data Mod (crs)

Data Breath (crs)

Data

Data Foot (crs)

Data Porta (crs)

Data Data (crs)

Data Vol (crs)

Data Bal (crs)

Data

Data Pan (crs)

Data Expr (crs)

Data Eff1 (crs)

Data Eff2 (crs)

Data ,

Data Sldr1

Data Sldr2

Data Sldr3

Data Sldr4

Data ,,,,,,,,,,,

Data Bank (fin)

Data Mod (fin)

Data Breath (fin)

Data

Data Foot (fin)

Data Porta (fin)

Data Data (fin)

Data Vol (fin)

Data Bal (fin)

Data

Data Pan (fin)

Data Expr (fin)

Data Eff1 (fin)

Data Eff2 (fin)

Data ,,,,,,,,,,,,,,,,,

Data Hold (+/-)

Data Porta (+/-)

Data Sust (+/-)

Data Soft (+/-)

Data Legato (+/-)

Data Hold2 (+/-)

Data Varia

Data Timbre

Data Release

Data Attack

Data Bright

Data SndCtrl 6

Data SndCtrl 7

Data SndCtrl 8

Data SndCtrl 9

Data SndCtrl 10

Data But1 (+/-)

Data But2 (+/-)

Data But3 (+/-)

Data But4 (+/-)

Data ,,,,,,

Data Fx Lev

Data Tremu

Data Chorus

Data Celeste

Data Phaser

Data Data But+

Data Data But-

Data NonPar (fin)

Data NonPar (crs)

Data RegPar (fin)

Data RegPar (crs)

Data ,,,,,,,,,,,,,,,,,

Data AllSnds-

Data AllCtrls-

Data Loc Kbrd (+/-)

Data AllNotes-

Data Omni-

Data Omni+

Data MonoOper

Data PolyOper

Local ls As String

 ls = Read$(cn + 1)

 Function = IIf$(Len(ls), ls, "(Unk)")

End Function 'GetControllerName

#Else 'verbose string functions

'**************************************

'returns the GM drum sound for note number "nn"

Function GetGMDrumSound(nn As Long) As String

'These are numbered beginning at 35

Data Acoustic Bass Drum

Data Bass Drum 1

Data Side Stick

Data Acoustic Snare

Data Hand Clap

Data Electric Snare

Data Low Floor Tom

Data Closed Hi-Hat

Data High Floor Tom

Data Pedal Hi-Hat

Data Low Tom

Data Open Hi-Hat

Data Low-Mid Tom

Data Hi-Mid Tom

Data Crash Cymbal 1

Data High Tom

Data Ride Cymbal 1

Data Chinese Cymbal

Data Ride Bell

Data Tambourine

Data Splash Cymbal

Data Cowbell

Data Crash Cymbal 2

Data Vibraslap

Data Ride Cymbal 2

Data Hi Bongo

Data Low Bongo

Data Mute Hi Conga

Data Open Hi Conga

Data Low Conga

Data High Timbale

Data Low Timbale

Data High Agogo

Data Low Agogo

Data Cabasa

Data Maracas

Data Short Whistle

Data Long Whistle

Data Short Guiro

Data Long Guiro

Data Claves

Data Hi Wood Block

Data Low Wood Block

Data Mute Cuica

Data Open Cuica

Data Mute Triangle

Data Open Triangle

 Function = Read$(nn - 34)

End Function 'GetGMDrumSound

'**************************************

'get verbose controller name

'cn is a zero-based controller number

Function GetControllerName(cn As Long) As String

'Defined Controllers

Data Bank Select

Data Modulation Wheel (coarse)

Data Breath controller (coarse)

Data

Data Foot Pedal (coarse)

Data Portamento Time (coarse)

Data Data Entry (coarse)

Data Volume (coarse)

Data Balance (coarse)

Data

Data Pan position (coarse)

Data Expression (coarse)

Data Effect Control 1 (coarse)

Data Effect Control 2 (coarse)

Data ,

Data General Purpose Slider 1

Data General Purpose Slider 2

Data General Purpose Slider 3

Data General Purpose Slider 4

Data ,,,,,,,,,,,

Data Bank Select (fine)

Data Modulation Wheel (fine)

Data Breath controller (fine)

Data

Data Foot Pedal (fine)

Data Portamento Time (fine)

Data Data Entry (fine)

Data Volume (fine)

Data Balance (fine)

Data

Data Pan position (fine)

Data Expression (fine)

Data Effect Control 1 (fine)

Data Effect Control 2 (fine)

Data ,,,,,,,,,,,,,,,,,

Data Hold Pedal (on/off)

Data Portamento (on/off)

Data Sustenuto Pedal (on/off)

Data Soft Pedal (on/off)

Data Legato Pedal (on/off)

Data Hold 2 Pedal (on/off)

Data Sound Variation

Data Sound Timbre

Data Sound Release Time

Data Sound Attack Time

Data Sound Brightness

Data Sound Control 6

Data Sound Control 7

Data Sound Control 8

Data Sound Control 9

Data Sound Control 10

Data General Purpose Button 1 (on/off)

Data General Purpose Button 2 (on/off)

Data General Purpose Button 3 (on/off)

Data General Purpose Button 4 (on/off)

Data ,,,,,,

Data Effects Level

Data Tremulo Level

Data Chorus Level

Data Celeste Level

Data Phaser Level

Data Data Button increment

Data Data Button decrement

Data Non-registered Parameter (fine)

Data Non-registered Parameter (coarse)

Data Registered Parameter (fine)

Data Registered Parameter (coarse)

Data ,,,,,,,,,,,,,,,,,

Data All Sound Off

Data All Controllers Off

Data Local Keyboard (on/off)

Data All Notes Off

Data Omni Mode Off

Data Omni Mode On

Data Mono Operation

Data Poly Operation

Local ls As String

 ls = Read$(cn + 1)

 Function = IIf$(Len(ls), ls, "(Unk)")

End Function 'GetControllerName

#EndIf

'**************************************

'pn is the zero-based patch index

Function GetPatchName(pn As Long) As String

'----------------------------------

'Piano

Data Acoustic Grand

Data Bright Acoustic

Data Electric Grand

Data ***** - Tonk

Data Electric Piano 1

Data Electric Piano 2

Data Harpsichord

Data Clav

'----------------------------------

'Chromatic Percussion

Data Celesta

Data Glockenspiel

Data Music Box

Data Vibraphone

Data Marimba

Data Xylophone

Data Tubular Bells

Data Dulcimer

'----------------------------------

'Organ

Data Drawbar Organ

Data Percussive Organ

Data Rock Organ

Data Church Organ

Data Reed Organ

Data Accoridan

Data Harmonica

Data Tango Accordian

'----------------------------------

'Guitar

Data Acoustic Guitar(nylon)

Data Acoustic Guitar(steel)

Data Electric Guitar(jazz)

Data Electric Guitar(clean)

Data Electric Guitar(muted)

Data Overdriven Guitar

Data Distortion Guitar

Data Guitar Harmonics

'----------------------------------

'Bass

Data Acoustic Bass

Data Electric Bass(finger)

Data Electric Bass(pick)

Data Fretless Bass

Data Slap Bass 1

Data Slap Bass 2

Data Synth Bass 1

Data Synth Bass 2

'----------------------------------

'Solo Strings

Data Violin

Data Viola

Data Cello

Data Contrabass

Data Tremolo Strings

Data Pizzicato Strings

Data Orchestral Strings

Data Timpani

'----------------------------------

'Ensemble

Data String Ensemble 1

Data String Ensemble 2

Data SynthStrings 1

Data SynthStrings 2

Data Choir Aahs

Data Voice Oohs

Data Synth Voice

Data Orchestra Hit

'----------------------------------

'Brass

Data Trumpet

Data Trombone

Data Tuba

Data Muted Trumpet

Data French Horn

Data Brass Section

Data SynthBrass 1

Data SynthBrass 2

'----------------------------------

'Reed

Data Soprano Sax

Data Sax

Data Tenor Sax

Data Baritone Sax

Data Oboe

Data English Horn

Data Bassoon

Data Clarinet

'----------------------------------

'Pipe

Data Piccolo

Data Flute

Data Recorder

Data Pan Flute

Data Blown Bottle

Data Skakuhachi

Data Whistle

Data Ocarina

'----------------------------------

'Synth Lead

Data Lead 1 (square)

Data Lead 2 (sawtooth)

Data Lead 3 (calliope)

Data Lead 4 (chiff)

Data Lead 5 (charang)

Data Lead 6 (voice)

Data Lead 7 (fifths)

Data Lead 8 (bass + lead)

'----------------------------------

'Synth Pad

Data Pad 1 (new age)

Data Pad 2 (warm)

Data Pad 3 (polysynth)

Data Pad 4 (choir)

Data Pad 5 (bowed)

Data Pad 6 (metallic)

Data Pad 7 (halo)

Data Pad 8 (sweep)

'----------------------------------

'Synth Effects

Data FX 1 (rain)

Data FX 2 (soundtrack)

Data FX 3 (crystal)

Data FX 4 (atmosphere)

Data FX 5 (brightness)

Data FX 6 (goblins)

Data FX 7 (echoes)

Data FX 8 (sci-fi)

'----------------------------------

'Ethnic

Data Sitar

Data Banjo

Data Shamisen

Data Koto

Data Kalimba

Data Bagpipe

Data Fiddle

Data Shanai

'----------------------------------

'Percussive

Data Tinkle Bell

Data Agogo

Data Steel Drums

Data Woodblock

Data Taiko Drum

Data Melodic Tom

Data Synth Drum

Data Reverse Cymbal

'----------------------------------

'Sound Effects

Data Guitar Fret Noise

Data Breath Noise

Data Seashore

Data Bird Tweet

Data Telephone Ring

Data Helicopter

Data Applause

Data Gunshot

 Function = Read$(pn + 1)

End Function 'GetPatchName

'**************************************

'for SysEx events

'mn is a one-based, manufacturer's ID number

'(not sure how up to date the list is)

Function GetManufacturerName(mn As Long) As String

'Here are the Manufacturer which have ID numbers assigned:

Data Sequential Circuits

Data Big Briar

Data Octave / Plateau

Data Moog 4

Data Passport Designs

Data Lexicon

Data Kurzweil

Data Fender

Data Gulbransen

Data Delta Labs

Data Sound Comp.

Data General Electro

Data Techmar

Data Matthews Research

Data

Data Oberheim

Data PAIA

Data Simmons

Data DigiDesign

Data Fairlight

Data JL Cooper

Data Lowery

Data Lin

Data Emu

Data ,

Data Peavey

Data ,,,

Data Bon Tempi

Data S.I.E.L.

Data

Data SyntheAxe

Data Hohner

Data Crumar

Data Solton

Data Jellinghaus Ms

Data CTS

Data PPG

Data ,,,,

Data Elka

Data ,,,,,

Data Cheetah

Data ,,,,,,

Data Waldorf

Data

Data Kawai

Data Roland

Data Korg

Data Yamaha

Data Casio

Data Akai

Local ls As String

 Select Case mn

 Case < &H46 : ls = Read$(mn)

 Case = &H7E : ls = "Non-RealTime (universal)"

 Case = &H7F : ls = "RealTime (universal)"

 End Select

 Function = IIf$(Len(ls), ls, "(Unk)")

End Function 'GetManufacturerName

'**************************************

'returns a variable-length data value

'this modifies p to point it at the last byte of

'variable-length data

Function VarLen(tk As String, ByRef p As Long) As Long

Local b As Long

Local n As Long

Local td As Dword

 Do

 Incr n

 b = Asc(tk, p)

 Shift Left td, 7

 td = td + (b And 127)

 If (b And &H80) = 0 Then Exit Do

 Incr p

 Loop While (n < 5) And (p <= Len(tk))

 Function = td

End Function

'**************************************

'Octave| | Note Numbers

' # | |

' | | C | C# | D | D# | E | F | F# | G | G# | A | A# | B

'-----------------------------------------------------------------------------

' 0 | | 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11

' 1 | | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23

' 2 | | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35

' 3 | | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47

' 4 | | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59

' 5 | | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71

' 6 | | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83

' 7 | | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95

' 8 | | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107

' 9 | | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119

' 10 | | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 |

Function GetNoteName(nn As Long) As String

 Function = Parse$($Notes, (nn Mod 12) + 1) & " (" & Format$(nn\12) & ")"

End Function 'GetNoteName

'**************************************

'returns a string to display the total

'delta-time ticks elapsed since the start of

'the current track

'resets the time if dt = &HFFFFFFFF???

Function FormatTime(dt As Dword) As String

Static tm As Quad

 If dt = &HFFFFFFFF??? Then tm = 0 : Exit Function 'reset the time

 tm = tm + dt 'update the time

 Function = Using$("#,", tm)

End Function 'FormatTime

'**************************************

'p must arrive pointing at the meta-event's code

Function DisMetaEvent(tk As String, ByVal p As Long, ByVal dt As Dword) As Long

Local ev As Long 'event code

Local n As Long

Local pf As Long '"Print#" flag

Local x As Long

Local ls As String

Local ts As String

Local td As Dword 'temporary DWord

 Dim ab(3) As Byte At VarPtr(td)

 'get the event code and channel number

 ev = Asc(tk, p)

 Incr p

 n = VarLen(tk, p)

 'get the event's data

 Incr p

 ls = Mid$(tk, p, n)

 Incr pf 'enable Print#-ing

 '----------------------------------

 'decode the event

 Select Case ev

 ' Set Track Sequence Number

 Case &H00

 td = CvWrd(ls)

 Swap ab(0), ab(1)

 ls = "Sequence= " & Format$(td)

 ' Text

 Case &H01

 ls = "Text {" & $Lf & ls & "}"

 ' Copyright Info

 Case &H02

 ls = "CopyRight {" & $Lf & ls & "}"

 ' Sequence or Track Name

 Case &H03

 ls = "TrackName {" & $Lf & ls & "}"

 ' Track Instrument Name

 Case &H04

 ls = "Instrument {" & $Lf & ls & "}"

 ' Lyric

 Case &H05

 ls = "Lyric {" & $Lf & ls & "}"

 ' Marker

 Case &H06

 ls = "Marker {" & $Lf & ls & "}"

 ' Cue Point

 Case &H07

 ls = "CuePoint {" & $Lf & ls & "}"

 ' MIDI Channel

 Case &H07

 ls = "MidiChannel= " & Format$(Asc(ls) + 1)

 ' Device Name Assigned to MIDI Port

 Case &H21

 x = Asc(ls)

 ls = "Error getting device name:" & $CrLf

 Select Case midiOutGetDevCaps(x, moc, SizeOf(MIDIOUTCAPS))

 Case %MMSYSERR_BADDEVICEID

 ls = ls & """The specified device identifier is out of range."""

 Case %MMSYSERR_INVALPARAM

 ls = ls & """The specified pointer or structure is invalid."""

 Case %MMSYSERR_NODRIVER

 ls = ls & """The driver is not installed."""

 Case %MMSYSERR_NOMEM

 ls = ls & """The system is unable to load mapper string description."""

 Case %MMSYSERR_NOERROR

 ls = "DeviceName= " & moc.szPname

 End Select

 ' End of Track

 Case &H2F

 ls = "EndOfTrack"

 ' Set Tempo

 Case &H51

 td = CvDwd(ls)

 GoSub ToggleEndian

 Shift Right td, 8

 tmpo = 60000000/td

 ls = "Tempo=" & Format$(tmpo) & " (" & Format$(td) & " mms per 1/4 note)"

 ' SMPTE Offset

 Case &H54 '(not implemented)

 ' Time Signature

 Case &H58

 ts = ls

 ls = "TimeSignature {" & $Lf

 ls = ls & Format$(Asc(ts, 1)) & "/" & Format$(2 ^ Asc(ts, 2)) & $Lf

 ls = ls & "Ticks/metronome click= " & Format$(Asc(ts, 3)) & $Lf

 ls = ls & "32nd notes/quarter= " & Format$(Asc(ts, 4)) & $Lf & "}"

 ' Key Signature

 Case &H59

 x = Asc(ls, 1)

 If Bit(x, 7) Then x = x Or &HFFFFFF00

 If x <> 0 Then

 ts = String$(Abs(x), IIf$(x > 0, "#", "b")) & IIf$(Asc(ls, 2), " Min", " Maj")

 Else

 ts = "(Nat)"

 End If

 ls = "KeySignature: " & ts

 ' Proprietary (sequencer-specific information)

 Case &H7F

 ts = ls

 ls = "Proprietary {" & $Lf

 ls = ls & "Program ID: " & Left$(ts, Min(4, Verify(ts, $Ascii) - 1)) & $Lf

 For x = 1 To Len(ts)

 ls = ls & Hex$(Asc(ts, x), 2) & $Spc

 If x Mod 16 = 0 Then ls = ls & $Lf

 Next x

 ls = ls & "}"

 Case Else

 ls = "UnkownMetaEvent: &H" & Hex$(ev, 2)

 End Select

 If pf Then

 Replace $Lf With $CrLf In ls

 Print# fo, FormatTime(dt) & $Tab & $EventPrefix & ls

 End If

 Function = p + n - 1

 Exit Function

ToggleEndian:

 Swap ab(0), ab(3)

 Swap ab(1), ab(2)

Return

End Function 'DisMetaEvent

'**************************************

Function DisTrack(tk As String) As Long

Local ev As Long

Local dt As Dword 'delta time

Local ch As Long 'channel

Local cn As Long 'controller number

Local nn As Long 'note number

Local ve As Long 'velocity

Local pn As Long 'patch number

Local pw As Long 'pitch wheel

Local nv As Long '"new value"

Local pf As Long '"Print#" flag

Local wf As Long 'warning flag

Local n As Long

Local p As Long

Local tc As String 'time and channel

Local ls As String

Local ts As String

 For p = 1 To Len(tk)

 dt = VarLen(tk, p) 'get the delta-time

 Incr p

 n = Asc(tk, p)

 'if no event byte is present, the last one is assumed to be intended

 If (n And 128) Then

 ev = n

 Incr p

 End If

 ch = (ev And 15) + 1

 ls = FormatTime(dt) & $Tab & "Ch=" & Format$(ch) & ": " & $EventPrefix

 Incr pf 'enable Print#-ing

 '----------------------------------

 'decode the event

 Select Case ev

 'just in case...

 Case < &H80

 ls = "Running Mode Error!"

 ' Note Off

 Case < &H90

 nn = Asc(tk, p)

 Incr p

 ve = Asc(tk, p)

 ls = Left$(ls, Len(ls) - 1) & " - " & IIf$(ch = 10, GetGMDrumSound(nn), GetNoteName(nn)) & $Tab & "V=" & Format$(ve)

 ' Note On

 Case < &HA0

 nn = Asc(tk, p)

 Incr p

 ve = Asc(tk, p)

 ls = Left$(ls, Len(ls) - 1) & IIf$(ve, "+ ", "z ") & IIf$(ch = 10, GetGMDrumSound(nn), GetNoteName(nn))

 ls = ls & IIf$(ve, $Tab & "V=" & Format$(ve), "")

 ' Key After-Touch

 Case < &HB0

 nn = Asc(tk, p)

 Incr p

 ve = Asc(tk, p)

 ls = ls & "Touch:" & $Tab & IIf$(ch = 10, GetGMDrumSound(nn), GetNoteName(nn)) & $Tab & "V=" & Format$(ve)

 ' Control Change

 Case < &HC0

 cn = Asc(tk, p)

 Incr p

 nv = Asc(tk, p)

 ls = ls & "Ctrl:" & GetControllerName(cn) & "=" & Format$(nv)

 ' Program (Patch) Change

 Case < &HD0

 pn = Asc(tk, p)

 ls = ls & "Patch= " & GetPatchName(pn)

 ' Channel Pressure

 Case < &HE0

 cn = Asc(tk, p)

 ls = ls & "ChanPress=" & Format$(cn)

 ' Pitch Wheel Change

 Case < &HF0

 pw = Asc(tk, p) And 127

 Incr p

 pw = pw + ((Asc(tk, p) And 127) * 128)

 ls = ls & "Wheel= " & Format$(pw - &H2000&)

 ' System Exclusive

 Case &HF0

 ls = FormatTime(dt) & $Tab & $EventPrefix & "SysEx: (hex format) {" & $CrLf

 n = p + VarLen(tk, p)

 ls = ls & "Manufacturer: " & GetManufacturerName(Asc(tk, p)) & $CrLf

 Do While p < n

 Incr p

 ls = ls & $Spc & Hex$(Asc(tk, p), 2)

 If (n - p) Mod 16 = 0 Then ls = ls & $CrLf

 Loop

 ls = ls & "}"

 'Song Position (not implemented)

 Case &HF2

 Incr wf

 ls = ls & "SongPosition"

 'Song Select (not implemented)

 Case &HF3

 Incr wf

 ls = ls & "SongSelect"

 'Unofficial Bus Select (not implemented)

 Case &HF5

 Incr wf

 ls = ls & "UnofficialBusSelect"

 'Tune Request (not implemented)

 Case &HF6

 Incr wf

 ls = ls & "TuneRequest"

 'End of SysEx

 'Case &HF7

 'this should always be caught in a SysEx event, so it's REM-ed out

 ' Incr wf

 ' ls = "}"

 'Timing Tick (not implemented)

 Case &HF8

 Incr wf

 ls = ls & "TimingTick"

 'Start Current Sequence (not implemented)

 Case &HFA

 Incr wf

 ls = ls & "StartCurrentSeq"

 'Continue Stopped Sequence (not implemented)

 Case &HFB

 Incr wf

 ls = ls & "ContinueSeq"

 'Stop Sequence (not implemented)

 Case &HFC

 Incr wf

 ls = ls & "StopSeq"

 'Active Sensing (not implemented)

 Case &HFE

 Incr wf

 ls = ls & "ActiveSensing"

 'Meta-Event

 Case &HFF

 p = DisMetaEvent(tk, p, dt)

 pf = 0

 End Select

 If pf Then Print# fo, ls

 If wf Then

 gs = "Found an unimplemented command, aborting track..."

 Msg gs

 Print# fo, gs

 Exit Function

 End If

 Next p

End Function

'**************************************

'if dr <> 0 then the file was dropped on to the

'dialog rather than dropped on the icon or entered

'at the command line.

Function MidiMain(dr As Long) As Long

Local fi As Long 'input file

Local n As Long

Local trks As Long 'number of tracks

Local tn As Long 'track number

Local tlen As Long 'track length

Local td As Dword 'temporary DWord

Local ls As String

Local tk As String

 Dim ab(3) As Byte At VarPtr(td)

 If dr = 0 Then

 If InStr(",H,HELP,-H,-HELP,/H,/HELP,", "," & UCase$(InFile) & ",") Then

 MsgBox $Help, %mb_iconinformation, $Caption

 Exit Function

 End If

 End If

 'add file extension if needed

 If InStr(InFile, ".") = 0 Then

 InFile = InFile & ".MID"

 ElseIf UCase$(Right$(InFile, 4)) <> ".MID" Then 'check file extension

 gs = "Error:" & $CrLf & "Incorrect file extension. It must be a "".MID"" file"

 If dr Then Msg gs Else MsgBox gs, %mb_iconerror, $Caption

 Exit Function

 End If

 If Len(Dir$(InFile)) = 0 Then

 gs = "Error: Couldn't find " & $CrLf & """" & InFile & """"

 If dr Then Msg gs Else MsgBox gs, %mb_iconerror, $Caption

 Exit Function

 End If

 OutFile = Left$(InFile, Len(InFile) - 3) & "txt"

 If Len(Dir$(OutFile)) Then

 If MsgBox("Over-write:" & $CrLf & OutFile & "?", %mb_yesno, $Caption) = %idno Then Exit Function

 End If

 '----------------------------------

 fi = FreeFile

 Open InFile For Binary As #fi

 fo = FreeFile

 Open OutFile For Output As #fo

 '----------------------------------

 Get$ #fi, 8, ls

 If ls <> $MidiHeader Then

 gs = "Error: bad header"

 If dr Then Msg gs Else MsgBox gs

 Exit Function

 End If

 '----------------------------------

 Get$ #fi, 2, ls 'get the track format

 Print# fo, "Format= " & Choose$(Asc(ls, 2) + 1, _

 "Single-Track", "Multi-Track, Synchronous", _

 "Multi-Track, Asynchronous")

 '----------------------------------

 Get$ #fi, 2, ls 'get number of tracks

 trks = (Asc(ls, 1) * 256) + Asc(ls, 2)

 Print# fo, "Tracks=" & Format$(trks)

 '-----------------------------------------------------------------------

 tmpo = 120 'set the default BPM

 Get$ #fi, 2, ls 'get the delta-time ticks per quarter note

 div = Asc(ls, 1)

 If Bit(div, 7) Then

 !'Note: This might not give correct results for SMPTE !

 sf = Abs(CLng(div Or &HFFFFFF00???))

 sr = Asc(ls, 2)

 tpq = sf * sr * 1000000.0

 ls = "SMPTE divisions per quarter-note= "

 Else

 tpq = (div * 256) + Asc(ls, 2)

 ls = "Delta-time ticks per quarter note= "

 End If

 Print# fo, ls & Format$(tpq)

 '----------------------------------

 'Dump the tracks

 Do

 '----------------------------------

 'get the track header

 Get$ #fi, 4, ls

 If ls <> "MTrk" Then Exit Do 'bad header

 Print# fo,

 Print# fo, "****************************************"

 '----------------------------------

 'get track's length in bytes

 Get$ #fi, 4, ls

 td = CvDwd(ls)

 Swap ab(0), ab(3)

 Swap ab(1), ab(2)

 tlen = td

 Print# fo, "Track=" & Format$(tn) & $Tab & "Bytes=" & Format$(tlen)

 Get$ #fi, tlen, tk 'get the track's contents

 FormatTime(&HFFFFFFFF???)

 DisTrack(tk)

 Incr tn 'next track number

 Loop Until Eof(1)

 Close# fi, #fo

 gs = "Done with """ & InFile & """." & $CrLf & "The output is in """ & OutFile & """"

 If dr Then Msg gs Else MsgBox gs

End Function 'MidiMain

'**************************************

CallBack Function ShowDlgProc()

Local n As Long

 Select Case As Long CbMsg

 Case %wm_initdialog

 Msg $Help

 DragAcceptFiles hDlg, %TRUE

 Case %WM_DROPFILES

 InFile = String$(%MAX_PATH, $Nul)

 n = DragQueryFile(CbWParam, -1, ByVal 0, 0)

 DragQueryFile CbWParam, 0, ByVal StrPtr(InFile), %MAX_PATH

 DragFinish CbWParam

 InFile = RTrim$(InFile, $Nul)

 Msg "Processing: """ & InFile & """"

 MidiMain 1

 Case %wm_command

 Select Case As Long CbCtl

 Case %idcancel

 Dialog End hDlg

 End Select

 End Select

End Function

'**************************************

Function PBMain() As Long

 Local lRslt As Long

 InFile = Trim$(Command$, Any " """)

 If Len(InFile) Then

 MidiMain 0

 Exit Function

 End If

 Dialog New %HWND_DESKTOP, $Caption, 286, 65, 189, 65, _

 %ws_popup Or %ws_border Or %ws_dlgframe Or %ws_caption Or _

 %ws_sysmenu Or %ws_minimizebox Or %ws_clipsiblings Or %ws_visible Or _

 %ds_modalframe Or %ds_3dlook Or %ds_nofailcreate Or %ds_setfont, _

 %ws_ex_acceptfiles Or %ws_ex_controlparent Or %ws_ex_left Or _

 %ws_ex_ltrreading Or %ws_ex_rightscrollbar, To hDlg

 Control Add Label, hDlg, %Lbl, "Drop "".MID"" files onto this window", _

 0, 4, 188, 14, %ws_child Or %ws_visible Or %ss_center, %ws_ex_left Or _

 %ws_ex_ltrreading

 Control Add TextBox, hDlg, %Txt, "", 0, 19, 188, 45, %ws_child Or _

 %ws_visible Or %ws_tabstop Or %es_left Or %es_multiline Or _

 %es_autohscroll Or %es_autovscroll Or %es_readonly, _

 %ws_ex_clientedge Or %ws_ex_left Or %ws_ex_ltrreading Or _

 %ws_ex_rightscrollbar

 Dialog Show Modal hDlg, Call ShowDlgProc To lRslt

 DragAcceptFiles hdlg, %FALSE

 Function = lRslt

End Function

'**************************************

نشان دادن ماژولهای مورد استفاده توسط پروسه ها

Fri, 20 Feb 2009 05:22:57 +0000

این کد ماژولهای هر پروسه ای رو همراه با ورژن اون نشون می ده :

کد: 
#Compile Exe

 #Dim All

 #Register None

 #Include "Win32Api.Inc"

 Global hDlg As Long, hFont As Dword

 %TH32CS_SNAPPROCESS = &H2& ' dwFlags for

 %TH32CS_SNAPMODULE = &H8& ' CreateToolhelp32Snapshot

 %MAX_MODULE_NAME32 = 255

 Type PROCESSENTRY32

 dwSize As Dword

 cntUsage As Dword

 th32ProcessID As Dword ' This process

 th32DefaultHeapID As Long Ptr

 th32ModuleID As Dword ' Associated exe

 cntThreads As Dword

 th32ParentProcessID As Dword ' This process's parent process

 pcPriClassBase As Long ' Base priority of process threads

 dwFlags As Dword

 szExeFile As Asciiz * %MAX_PATH ' Path

 End Type

 Type MODULEENTRY32

 dwSize As Dword

 th32ModuleID As Dword ' This module

 th32ProcessID As Dword ' Owning process

 GlblcntUsage As Dword ' Global usage count on the module

 ProccntUsage As Dword ' Module usage count in th32ProcessID's context

 modBaseAddr As Byte Ptr ' Base address of module in th32ProcessID's context

 modBaseSize As Dword ' Size in bytes of module starting at modBaseAddr

 hModule As Dword ' The hModule of this module in th32ProcessID's context

 szModule As Asciiz * (%MAX_MODULE_NAME32 + 1)

 szExePath As Asciiz * %MAX_PATH

 End Type

 Declare Function CreateToolhelp32Snapshot (ByVal dwFlags As Dword, ByVal th32ProcessID As Dword) As Long

 Declare Function Process32First (ByVal hSnapshot As Dword, pe As PROCESSENTRY32) As Long

 Declare Function Process32Next (ByVal hSnapshot As Dword, pe As PROCESSENTRY32) As Long

 Declare Function Module32First (ByVal hSnapshot As Dword, Me As MODULEENTRY32) As Long

 Declare Function Module32Next (ByVal hSnapshot As Dword, Me As MODULEENTRY32) As Long

 Declare Function EnumProcesses (idProcess As Dword, ByVal cb As Dword, cbNeeded As Dword) As Long

 Declare Function GetModuleFileNameEx (ByVal hProcess As Dword, ByVal hModule As Dword, ModuleName As Asciiz, ByVal nSize As Dword) As Dword

 Declare Function EnumProcessModules (ByVal hProcess As Dword, hModule As Dword, ByVal cb As Dword, cbNeeded As Dword) As Long

 Declare Function GetVersionStringInfo (ByVal Fname As String) As String

 Declare Function MakeFontEx(ByVal FontName As String, ByVal PointSize As Long, ByVal fBold As Long, _

 ByVal fItalic As Long, ByVal fUnderline As Long) As Long

 %ID_LISTBOX = 1001

 Sub EnumModules

 Dim hKernel32 As Local Dword

 Dim hCreateToolhelp32Snapshot As Local Dword

 Dim hProcess32Next As Local Dword

 Dim hProcess32First As Local Dword

 Dim hModule32First As Local Dword

 Dim hModule32Next As Local Dword

 Dim hPsApiDll As Local Dword

 Dim hEnumProcesses As Local Dword

 Dim hGetModuleFileNameEx As Local Dword

 Dim hEnumProcessModules As Local Dword

 Dim os As Local OSVERSIONINFO

 Dim pe As Local PROCESSENTRY32

 Dim mee As Local MODULEENTRY32

 Dim hProcessSnap As Local Dword

 Dim hModuleSnap As Local Dword

 Dim nModules As Local Dword

 Dim nProcesses As Local Dword

 Dim hProcess As Local Dword

 Dim lResult1 As Local Long

 Dim lResult2 As Local Long

 Dim cb As Local Dword

 Dim cbNeeded As Local Dword

 Dim i As Local Dword

 Dim j As Local Dword

 os.dwOSVersionInfoSize = SizeOf(os)

 GetVersionEx ByVal VarPtr(os)

 ListBox Reset hDlg, %ID_LISTBOX

 If IsFalse(os.dwPlatformId = %VER_PLATFORM_WIN32_NT) Then ' Windows 95/98

 hKernel32 = GetModuleHandle("kernel32.dll")

 hCreateToolhelp32Snapshot = GetProcAddress(hKernel32, "CreateToolhelp32Snapshot")

 hProcess32Next = GetProcAddress(hKernel32, "Process32Next")

 hProcess32First = GetProcAddress(hKernel32, "Process32First")

 hModule32First = GetProcAddress(hKernel32, "Module32First")

 hModule32Next = GetProcAddress(hKernel32, "Module32Next")

 Call Dword hCreateToolhelp32Snapshot Using CreateToolhelp32Snapshot (%TH32CS_SNAPPROCESS, 0&) To hProcessSnap

 If hProcessSnap <> %INVALID_HANDLE_VALUE Then

 pe.dwSize = SizeOf(pe)

 Call Dword hProcess32First Using Process32First (hProcessSnap, pe) To lResult1

 While lResult1

 ListBox Add hDlg, %ID_LISTBOX, pe.szExeFile

 Call Dword hCreateToolhelp32Snapshot Using CreateToolhelp32Snapshot(%TH32CS_SNAPMODULE, pe.th32ProcessID) To hModuleSnap

 If hModuleSnap <> %INVALID_HANDLE_VALUE Then

 mee.dwSize = SizeOf(MODULEENTRY32)

 Call Dword hModule32First Using Module32First (hModuleSnap, mee) To lResult2

 While lResult2

 If pe.th32ModuleID <> mee.th32ModuleID Then _

 ListBox Add hDlg, %ID_LISTBOX, " " + _

 LSet$(GetVersionStringInfo(mee.szExePath),16) + mee.szExePath

 Call Dword hModule32Next Using Module32Next (hModuleSnap, mee) To lResult2

 Wend

 CloseHandle hModuleSnap

 ListBox Add hDlg, %ID_LISTBOX, "--------------------------------"

 End If

 Call Dword hProcess32Next Using Process32Next (hProcessSnap, pe) To Lresult1

 Wend

 CloseHandle hProcessSnap

 End If

 Else ' Windows NT

 hPsApiDll = GetModuleHandle("psApi.dll"): If hPsApiDll = 0 Then hPsApiDll = LoadLibrary("psApi.dll")

 hEnumProcesses = GetProcAddress(hPsApiDll, "EnumProcesses")

 hGetModuleFileNameEx = GetProcAddress(hPsApiDll, "GetModuleFileNameExA")

 hEnumProcessModules = GetProcAddress(hPsApiDll, "EnumProcessModules")

 cb = 100

 Do

 ReDim ProcessIDs(1 To cb \ 4) As Dword

 Call Dword hEnumProcesses Using EnumProcesses (ProcessIDs(1), cb, cbNeeded) To lResult1

 If cb > cbNeeded Then Exit Do

 cb = cb + cb

 Loop

 nProcesses = cbNeeded \ 4

 For i = 1 To nProcesses

 hProcess = OpenProcess(%PROCESS_QUERY_INFORMATION Or %PROCESS_VM_READ, %False, ProcessIDs(i))

 If hProcess Then

 cb = 100

 Do

 ReDim Modules(1 To cb / 4) As Dword

 Call Dword hEnumProcessModules Using EnumProcessModules (hProcess, Modules(1), cb, cbNeeded) To lResult1

 If lResult1 = 0 Then cbNeeded = 0: Exit Do

 If cb > cbNeeded Then Exit Do Else cb = cb * 2

 Loop

 nModules = cbNeeded / 4

 For j = 1 To nModules

 Call Dword hGetModuleFileNameEx Using GetModuleFileNameEx (hProcess, Modules(j), pe.szExeFile, SizeOf(pe.szExeFile)) To lResult1

 If lResult1 Then If j = 1 Then ListBox Add hDlg, %ID_LISTBOX, pe.szExeFile Else _

 ListBox Add hDlg, %ID_LISTBOX, " " + _

 LSet$(GetVersionStringInfo(pe.szExeFile),16)+ _

 pe.szExeFile

 Next

 CloseHandle hProcess

 ListBox Add hDlg, %ID_LISTBOX, "--------------------------------"

 End If

 Next

 End If

 End Sub

 CallBack Function DlgProc

 Select Case CbMsg

 Case %wm_initdialog

 Control Add ListBox, CbHndl, %ID_LISTBOX, , 0, 0, 0, 0, %ws_child Or %ws_vscroll, %ws_ex_clientedge

 hFont = MakeFontEx("System", 10,%FW_LIGHT, 0, 0) 'create desired font

 Control Send CbHndl, %ID_LISTBOX, %WM_SETFONT, hFont, 0 'tell control to use it

 EnumModules

 Case %wm_size

 Dim rc As RECT

 GetClientRect CbHndl, rc

 SetWindowPos GetDlgItem(CbHndl, %ID_LISTBOX), 0, _

 0.03 * rc.nRight, 0.02 * rc.nBottom, 0.94 * rc.nRight, _

 0.96 * rc.nBottom, %SWP_NOACTIVATE Or %SWP_NOZORDER

 End Select

 End Function

 Function PBMain

 Dialog New 0, "Processes and modules with version info", , , 400, 200, %ws_sysmenu Or %ws_caption Or %ws_thickframe Or %ds_modalframe To hDlg

 Dialog Show Modal hDlg Call DlgProc

 DeleteObject hFont

 End Function

 '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤

 ' Retrieve a system file's version number.. Borrowed from Borje Hagsten

 '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤

 Function GetVersionStringInfo(ByVal Fname As String) As String

 Local lRes As Long, lZero As Long, sBuf As String, tWFD As WIN32_FIND_DATA

 Local zFile As Asciiz * %MAX_PATH, pFI As VS_FIXEDFILEINFO Ptr

 zFile = zFile + Fname

 lRes = FindFirstFile(zFile, tWFD) 'see if it exists

 If lRes = %INVALID_HANDLE_VALUE Then Exit Function

 FindClose lRes

 lRes = GetFileVersionInfoSize(zFile, lZero) 'can we get any info?

 If lRes = 0 Then Exit Function

 sBuf = Space$(lRes) 'allocate space

 GetFileVersionInfo zFile, lRes, lRes, ByVal StrPtr(sBuf) 'get version info

 VerQueryValue ByVal StrPtr(sBuf), "\", pFI, lRes 'get VS_FIXEDFILEINFO info

 'build answer

 sBuf = Format$(HiWrd(@pFI.dwFileVersionMS), "0") & "." & _ 'Major part

 Format$(LoWrd(@pFI.dwFileVersionMS), "00")& "." 'Minor part

 If @pFI.dwFileVersionLS Then 'rem out to get version only..

 sBuf = sBuf & Format$(HiWrd(@pFI.dwFileVersionLS), "00") & "." & _ 'Major part

 Format$(LoWrd(@pFI.dwFileVersionLS), "0") 'Minor part

 End If

 Function = sBuf

 End Function

 '==========================================================================

 ' Routine to Change Font Original code by Dave Navarro & Borje Hagsten

 '==========================================================================

 Function MakeFontEx(ByVal FontName As String, ByVal PointSize As Long, ByVal fBold As Long, _

 ByVal fItalic As Long, ByVal fUnderline As Long) As Long

 Local hDC As Dword, CyPixels As Long

 hDC = GetDC(%HWND_DESKTOP)

 CyPixels = GetDeviceCaps(hDC, %LOGPIXELSY)

 ReleaseDC %HWND_DESKTOP, hDC

 PointSize = 0 - (PointSize * CyPixels) \ 72

 Function = CreateFont( _

 PointSize, 0, _ 'height, width(default=0)

 0, 0, _ 'escapement(angle), orientation

 fBold, _ 'weight (%FW_DONTCARE = 0, %FW_NORMAL = 400, %FW_BOLD = 700)

 fItalic, _ 'Italic

 fUnderline, _ 'Underline

 %FALSE, _ 'StrikeThru - who needs it?

 %ANSI_CHARSET, %OUT_TT_PRECIS, _

 %CLIP_DEFAULT_PRECIS, %DEFAULT_QUALITY, _

 %FF_MODERN+%FIXED_PITCH , ByCopy FontName)

 End Function

هوک کردن پیغام های ارسالی بین پنجره ها

Mon, 16 Feb 2009 16:35:54 +0000

این برنامه هر نوع کاری را که باعث فرستادن پیغام شود هوک کرده و پیغام آن را باز می گرداند

مثل حرکت ماوس،کلیک،فشردن یک کلید از کیبورد و هر کار دیگری

MsgViewer.zip (اندازه: 4.37 KB / تعداد دفعات دریافت: 220)

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

Sun, 15 Feb 2009 12:18:03 +0000

برنامه PwrDev یک محیط برای طراحی فرمها برای کامپایلر پاوربیسیک بود که در ورژن جدید آن

که در همین ماه میلادی سال 2009 منتشر شد امکانات بسیار زیادی به آن اضافه شد

و در این محیط دیگر نیازی به نصب خوده کامپایلر پاوربیسیک ندارید

این ورژن از پاوربیسیک ویندوز 9 و کنسول 5 پشتیبانی کامل می کند و قابلیت اجرا روی لینوکس را نیز داراست

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

این محیط به شما این امکان را می دهد که برنامه های خود را بر اساس .Net و FrameWork بسازید

شما می توانید در ساخت برنامه های خود از زبانهای دیگر نظیر #C و VB.Net در کنار پاوربیسیک بهره بگیرید

شما به طور مستقیم کنترل های .Net را در برنامه خود به کار بگیرید

PwrDev از هر دو مدل DDT و SDK برای ساخت برنامه های Win32 و کنسول پشتیبانی می کند

برای کار با این محیط داشتن دانش بسیار ساده و کم درباره API ها کافیست

خروجی این محیط می تواند :

نقل قول:
Windows applications (PB/WIN, PB/CC)

Console(PB/WIN, PB/CC)

CGI(PB/WIN, PB/CC)

NT-service(PB/WIN, PB/CC)

Libraries(PB/WIN)

Controlpanel applets(PB/WIN)

Excel Addins

باشد

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

از نظر ActiveX های PwrDev از موارد زیر پشتیبانی می کند

نقل قول:
ATL

JACOMPB

IStream interface

XLS functions

XML functions

که قدرت زیادی به شما در ساخت برنامه می بخشد

از نظر برنامه نویسی شی گرا نیز این محیط قدرت زیادی دارد و به صورت اتوماتیک به ساخت و توضیح

کلاسهای و اشیا آنها می پردازد

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

می پردازد که مهمترین این توابع برای کار با موارد زیر تعبیه شده اند

نقل قول:
Clipboard

Functions for standard and common controls like CheckBox, listbox, listview,...

Resources (rc)

INIfile

Registry

GDIPlus

Image support like JPG, GIF

Printer

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

دسترسی و از آنها استفاده کنید مثل Dialog ها و دیگر کنترلها مثل Winsock و Innet و دیگر کنترلها

و کامپونت های موجود در کامپیوتر شما

برای کار با Database هم این محیط کار را ساده کرده است و به جز قابلیتهای خوده پاوربیسیک

به شما اجازه استفاده از ADO و نسخه های 2 و 3 SQLite را می دهد

برنامه های شما می تواند Webbaced باشد

این محیط حتی برای فشرده سازی فایلها نیز دستوراتی دارد و از LZExpand و ZLIB نسخه 1.14 پشتیبانی می کند

از نظر تنظیمات هم برای پروژه های شما کارهای زیادی شده تا برنامه در سطح بالاتری بهینه سازی شود

حداقل سیستم مورد نیاز برای این محیط ویندوز98 است که ویندوز XP پیشنهاد می شود

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

مانیتوریگ یک تابع API

Thu, 12 Feb 2009 17:46:54 +0000

این کد کارش اینه که بی خود و بی جهت تابع ShellExecuteEx رو با پارامترهای اشتباه فراخوانی می کنه

که منجر به بروز خطا می شه

و سپس کارهای انجام شده را نظارت کرده و خطا را پیدا می کند

MonitorAPI.zip (اندازه: 1.79 KB / تعداد دفعات دریافت: 267)

نمایش درختی کلیدهای رجیستری

Mon, 09 Feb 2009 11:36:11 +0000

نمایش درختی کلیدهای رجیستری

کد: 
#Compile Exe

#Option Version5

#Dim All

#Register All

#Include "win32api.inc"

#Include "commctrl.inc"

         %max_computername_length = 15

'------------------------------------------------------------------------------

%id_reg_treeview            = 100

'------------------------------------------------------------------------------

Global shivelist()          As String   ' hive path strings

Global lhivelistcount       As Long     ' array index counter

Global ltotalhivecount      As Long     ' can be removed

Global hregtreeview         As Long     ' treeview handle

'------------------------------------------------------------------------------

'------------------------------------------------------------------------------

Function tvgettext(ByVal hparent As Long, ByVal hcontrol As Long, ByVal htvitem As Long) As String

    Local ztext As Asciiz * %max_dir

    Local ltvitem As tv_item

    ltvitem.hitem = htvitem

    ltvitem.mask = %tvif_text

    ltvitem.psztext = VarPtr(ztext)

    ltvitem.cchtextmax = %max_dir

    treeview_getitem(getdlgitem(hparent, hcontrol), ltvitem)

    Function = ztext

End Function

'------------------------------------------------------------------------------

Function tvsettext(ByVal hparent As Long, ByVal hcontrol As Long, ByVal htvitem As Long, ByVal stxt As String) As Long

    Local tvedititem As tv_item

    tvedititem.mask = %tvif_handle Or %tvif_text

    tvedititem.hitem = htvitem

    tvedititem.cchtextmax = %max_dir

    tvedititem.psztext = StrPtr(stxt)

    Function = treeview_setitem(getdlgitem(hparent, hcontrol), tvedititem)

End Function

'------------------------------------------------------------------------------

Function tvgetfullpath(ByVal hparent As Long, ByVal hcontrol As Long, ByVal htvitem As Long) As String

    Local strpath As String

    Local hcurrent As Dword

    hcurrent = htvitem

    Do Until hcurrent = 0

        strpath = tvgettext( hparent, hcontrol, hcurrent ) & "\" & strpath

        hcurrent = treeview_getparent( getdlgitem(hparent, hcontrol) , hcurrent )

    Loop

    Function = RTrim$( strpath, "\" )

End Function

'------------------------------------------------------------------------------

Function tvselectitem(ByVal hparent As Long, ByVal hcontrol As Long, ByVal htvitem As Long) As Long

    Function = treeview_select(getdlgitem(hparent, hcontrol), htvitem, %tvgn_caret)

End Function

'------------------------------------------------------------------------------

Function tvexpand(ByVal hparent As Long, ByVal hcontrol As Long, ByVal htvitem As Long) As Long

    Function = treeview_expand(getdlgitem(hparent, hcontrol), htvitem, %tve_expand)

End Function

'------------------------------------------------------------------------------

Function tvinsertitem(ByVal htree As Long, ByVal hparent As Long, stxt As String) As Long

    Local tv_insert As tv_insertstruct

    Local tv_itm   As tv_item

    If hparent Then

        tv_itm.mask      = %tvif_children Or %tvif_handle

        tv_itm.hitem     = hparent

        tv_itm.cchildren = 1

        treeview_setitem(htree, tv_itm)

    End If

    tv_insert.hparent              = hparent

    tv_insert.item.item.mask       = %tvif_state Or %tvif_text Or %tvif_image Or %tvif_selectedimage

    tv_insert.item.item.psztext    = StrPtr(stxt)

    tv_insert.item.item.cchtextmax = Len(stxt)

    Function = treeview_insertitem(htree, tv_insert)

End Function

'------------------------------------------------------------------------------

Function computername As String

    Dim retcode     As Long

    Dim lpbuffer    As Asciiz * %max_computername_length + 1

    Dim nsize       As Long

    nsize = %max_computername_length + 1

    retcode = getcomputername(lpbuffer,nsize)

    Function = UCase$(Trim$(lpbuffer))

End Function

'------------------------------------------------------------------------------

Function enumregsubkeys(hivekey As Long, zstartsubkey As Asciiz) As Long

    Local hkey          As Long

    Local dwindex       As Long

    Local lastwritetime As filetime

    Local zname         As Asciiz * %max_path

    Local zclass        As Asciiz * %max_path

    If regopenkeyex(hivekey, zstartsubkey, 0, %key_enumerate_sub_keys Or %key_all_access, hkey) = %error_success Then

        Do

            Sleep(0)

                                                               'sizeof(zname)             sizeof(zclass)

            If regenumkeyex(hkey, dwindex, ByVal VarPtr(zname), %max_path, %null, zclass, %max_path, lastwritetime) = %error_success Then

                If Trim$(zstartsubkey) = "" Then

                    ReDim Preserve shivelist(lhivelistcount)

                    shivelist(lhivelistcount) = zname

                    Incr lhivelistcount

                    ' ** do a recursive search for more 'local' entries...

                    enumregsubkeys hivekey, zname

                Else

                    ReDim Preserve shivelist(lhivelistcount)

                    shivelist(lhivelistcount) = zstartsubkey & "\" & zname

                    Incr lhivelistcount

                    ' ** do a recursive search for more 'global' entries...

                    enumregsubkeys hivekey, zstartsubkey & "\" & zname

                End If

                ' ** update index

                Incr dwindex

            Else

                Exit Do

            End If

        Loop

        regclosekey hkey

    End If

End Function

'------------------------------------------------------------------------------

Sub getregpathstr(ByVal lreghivehandle As Long, ByVal hivekey As Long)

    Local lcnt As Long

    Local sregpathstr As String

    Local lregpathlen As Long

    ' ** prepare counter and arrays for new data

    lhivelistcount = 0

    ' ** setup the treeview handle array

    Dim reghivehandlelist(0) As Long

    reghivehandlelist(0) = lreghivehandle

    ' ** setup the registry path string array

    Dim shivelist(0)

    ' ** get the subkeys for the hive

    Call enumregsubkeys(hivekey, "")

    ' ** fill treeview with registry path data from shivelist array

    For lcnt = 0 To UBound(shivelist)

        ' ** get registry path string

        sregpathstr = shivelist(lcnt)

        ' ** get number of keys/nodes in the registry path

        lregpathlen = ParseCount(sregpathstr,"\")

        If lregpathlen < 1 Then lregpathlen = 1

        ' ** prepare array for the new treeview item handle

        ReDim Preserve reghivehandlelist(lregpathlen)

        ' ** insert registry path item into treeview and update reghivehandlelist

        reghivehandlelist(lregpathlen) = tvinsertitem(hregtreeview, reghivehandlelist(lregpathlen-1), Parse$(sregpathstr,"\",lregpathlen) )

    Next

    ' ** release the arrays

    Erase shivelist()

    Erase reghivehandlelist()

    ltotalhivecount = ltotalhivecount + lhivelistcount ' can be removed

End Sub

CallBack Function hdlgproc() As Long

    Local trect         As rect             ' size dialog

    Static hroot        As Long

    Static hhkcr        As Long

    Static hhkcu        As Long

    Static hhklm        As Long

    Static hhku         As Long

    Static hhkcc        As Long

    Local lptv          As nm_treeview Ptr  ' treeview

    Local lpnmh         As nmhdr Ptr        ' treeview

    Static htreeitem    As Long             ' treeview, the selected item

    Static htime        As Long             ' can be removed

    Local ltime1, ltime2 As Long ' can be removed

    Select Case CbMsg

        Case %wm_initdialog

            hroot = tvinsertitem(hregtreeview, 0, computername)

            hhkcr = tvinsertitem(hregtreeview, hroot, "hkey_classes_root")

            hhkcu = tvinsertitem(hregtreeview, hroot, "hkey_current_user")

            hhklm = tvinsertitem(hregtreeview, hroot, "hkey_local_machine")

            hhku  = tvinsertitem(hregtreeview, hroot, "hkey_users")

            hhkcc = tvinsertitem(hregtreeview, hroot, "hkey_current_config")

             htime = tvinsertitem(hregtreeview, 0, "load time: ")

            tvexpand(CbHndl, %id_reg_treeview, hroot)

            postmessage CbHndl, %wm_user + 1000, 0, 0

        Case %wm_user + 1000

            tvsettext(CbHndl, %id_reg_treeview, hroot, "reading registry... ")

             ltime1 = Timer

            tvselectitem(CbHndl, %id_reg_treeview, hhkcr)

            Call getregpathstr(hhkcr, %hkey_classes_root)

            tvselectitem(CbHndl, %id_reg_treeview, hhkcu)

            Call getregpathstr(hhkcu, %hkey_current_user)

            tvselectitem(CbHndl, %id_reg_treeview, hhklm)

            Call getregpathstr(hhklm, %hkey_local_machine)

            tvselectitem(CbHndl, %id_reg_treeview, hhku)

            Call getregpathstr(hhku, %hkey_users)

            tvselectitem(CbHndl, %id_reg_treeview, hhkcc)

            Call getregpathstr(hhkcc, %hkey_current_config)

             ltime2 = Timer

             tvsettext(CbHndl, %id_reg_treeview, htime, "load time: " & Format$(ltotalhivecount) & _

             " registry keys in " & Format$(ltime2-ltime1) & _

             " seconds (" & Format$(ltotalhivecount \ (ltime2-ltime1)) & " keys/sec)" ) ' can be removed

            tvsettext(CbHndl, %id_reg_treeview, hroot, computername)

            tvselectitem(CbHndl, %id_reg_treeview, hroot)

     Case %wm_notify

         lpnmh = CbLParam

            lptv = CbLParam

         Select Case CbCtl

              Case %id_reg_treeview

                  Select Case @lpnmh.code

                       Case %tvn_selchangingn

                            htreeitem = @lptv.itemnew.hitem

                            Dialog Set Text CbHndl, $Spc & tvgetfullpath(CbHndl, %id_reg_treeview, htreeitem)

                            Function = 0

                            Exit Function

                        Case %tvn_itemexpanded

               htreeitem = @lptv.itemnew.hitem

                            tvselectitem(CbHndl, %id_reg_treeview, htreeitem)

                            Function = 0

                            Exit Function

                    End Select

            End Select

       Case %wm_command

      Select Case CbCtl

               Case %idcancel

                    If CbCtlMsg = %bn_clicked Then Dialog End CbHndl, 0

            End Select

        Case %wm_size

            getclientrect CbHndl, trect

            movewindow(hregtreeview, 1, 1, trect.nright-2, trect.nbottom-2, 1)

        Case %wm_destroy

    End Select

End Function

Function PBMain() As Long

    Local hdlg As Long

    Dialog New Pixels, 0, "registry to treeview",,, 400, 300, %ws_child Or %ws_sysmenu Or _

                %ws_maximizebox Or %ws_minimizebox Or %ws_caption Or %ws_thickframe To hdlg

    Control Add "systreeview32", hdlg, %id_reg_treeview, "", 0, 0, 0, 0, _

                %ws_child Or %ws_visible Or %tvs_hasbuttons Or %tvs_haslines Or _

                %tvs_linesatroot Or %tvs_showselalways, %ws_ex_clientedge

    Control Handle hdlg, %id_reg_treeview To hregtreeview

    Dialog Show Modal hdlg Call hdlgproc

End Function

اطلاعات Header فایل های PE

Tue, 03 Feb 2009 18:36:52 +0000

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

درباره Header یک فایل PE در اختیار ما می ذاره

البته کامل نیست چون مثلا خوده Image_Optional_Header32_Struct اطلاعات زیادی داره که

توی این برنامه فقط مهمترین هاش رو نمایش می ده اما خودتون اگه به ساختار این هدر آشنا باشید

می تونید برنامه رو کامل کنید

البته من هم در آینده یه برنامه برای کار با فایلهای PE می ذارم که وقتی سورس همین برنامه ها

رو ببینید می فهمید نوشتن همچین برنامه هایی اصلا سخت نیست

peheaders.JPG (اندازه: 45.81 KB / تعداد دفعات دریافت: 112)

PEHeader.zip (اندازه: 4.77 KB / تعداد دفعات دریافت: 243)